module Data.X509.Validation
(
module Data.X509.Validation.Types
, Fingerprint(..)
, FailedReason(..)
, SignatureFailure(..)
, ValidationChecks(..)
, ValidationHooks(..)
, defaultChecks
, defaultHooks
, validate
, validateDefault
, getFingerprint
, module Data.X509.Validation.Cache
, module Data.X509.Validation.Signature
) where
import Control.Applicative
import Control.Monad (when)
import Data.Default.Class
import Data.ASN1.Types
import Data.Char (toLower)
import Data.X509
import Data.X509.CertificateStore
import Data.X509.Validation.Signature
import Data.X509.Validation.Fingerprint
import Data.X509.Validation.Cache
import Data.X509.Validation.Types
import Data.Hourglass
import System.Hourglass
import Data.Maybe
import Data.List
data FailedReason =
UnknownCriticalExtension
| Expired
| InFuture
| SelfSigned
| UnknownCA
| NotAllowedToSign
| NotAnAuthority
| AuthorityTooDeep
| NoCommonName
| InvalidName String
| NameMismatch String
| InvalidWildcard
| LeafKeyUsageNotAllowed
| LeafKeyPurposeNotAllowed
| LeafNotV3
| EmptyChain
| CacheSaysNo String
| InvalidSignature SignatureFailure
deriving (Int -> FailedReason -> ShowS
[FailedReason] -> ShowS
FailedReason -> String
(Int -> FailedReason -> ShowS)
-> (FailedReason -> String)
-> ([FailedReason] -> ShowS)
-> Show FailedReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailedReason] -> ShowS
$cshowList :: [FailedReason] -> ShowS
show :: FailedReason -> String
$cshow :: FailedReason -> String
showsPrec :: Int -> FailedReason -> ShowS
$cshowsPrec :: Int -> FailedReason -> ShowS
Show,FailedReason -> FailedReason -> Bool
(FailedReason -> FailedReason -> Bool)
-> (FailedReason -> FailedReason -> Bool) -> Eq FailedReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FailedReason -> FailedReason -> Bool
$c/= :: FailedReason -> FailedReason -> Bool
== :: FailedReason -> FailedReason -> Bool
$c== :: FailedReason -> FailedReason -> Bool
Eq)
data ValidationChecks = ValidationChecks
{
ValidationChecks -> Bool
checkTimeValidity :: Bool
, ValidationChecks -> Maybe DateTime
checkAtTime :: Maybe DateTime
, ValidationChecks -> Bool
checkStrictOrdering :: Bool
, ValidationChecks -> Bool
checkCAConstraints :: Bool
, ValidationChecks -> Bool
checkExhaustive :: Bool
, ValidationChecks -> Bool
checkLeafV3 :: Bool
, ValidationChecks -> [ExtKeyUsageFlag]
checkLeafKeyUsage :: [ExtKeyUsageFlag]
, ValidationChecks -> [ExtKeyUsagePurpose]
checkLeafKeyPurpose :: [ExtKeyUsagePurpose]
, ValidationChecks -> Bool
checkFQHN :: Bool
} deriving (Int -> ValidationChecks -> ShowS
[ValidationChecks] -> ShowS
ValidationChecks -> String
(Int -> ValidationChecks -> ShowS)
-> (ValidationChecks -> String)
-> ([ValidationChecks] -> ShowS)
-> Show ValidationChecks
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationChecks] -> ShowS
$cshowList :: [ValidationChecks] -> ShowS
show :: ValidationChecks -> String
$cshow :: ValidationChecks -> String
showsPrec :: Int -> ValidationChecks -> ShowS
$cshowsPrec :: Int -> ValidationChecks -> ShowS
Show,ValidationChecks -> ValidationChecks -> Bool
(ValidationChecks -> ValidationChecks -> Bool)
-> (ValidationChecks -> ValidationChecks -> Bool)
-> Eq ValidationChecks
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationChecks -> ValidationChecks -> Bool
$c/= :: ValidationChecks -> ValidationChecks -> Bool
== :: ValidationChecks -> ValidationChecks -> Bool
$c== :: ValidationChecks -> ValidationChecks -> Bool
Eq)
data ValidationHooks = ValidationHooks
{
ValidationHooks -> DistinguishedName -> Certificate -> Bool
hookMatchSubjectIssuer :: DistinguishedName -> Certificate -> Bool
, ValidationHooks -> DateTime -> Certificate -> [FailedReason]
hookValidateTime :: DateTime -> Certificate -> [FailedReason]
, ValidationHooks -> String -> Certificate -> [FailedReason]
hookValidateName :: HostName -> Certificate -> [FailedReason]
, ValidationHooks -> [FailedReason] -> [FailedReason]
hookFilterReason :: [FailedReason] -> [FailedReason]
}
defaultChecks :: ValidationChecks
defaultChecks :: ValidationChecks
defaultChecks = ValidationChecks :: Bool
-> Maybe DateTime
-> Bool
-> Bool
-> Bool
-> Bool
-> [ExtKeyUsageFlag]
-> [ExtKeyUsagePurpose]
-> Bool
-> ValidationChecks
ValidationChecks
{ checkTimeValidity :: Bool
checkTimeValidity = Bool
True
, checkAtTime :: Maybe DateTime
checkAtTime = Maybe DateTime
forall a. Maybe a
Nothing
, checkStrictOrdering :: Bool
checkStrictOrdering = Bool
False
, checkCAConstraints :: Bool
checkCAConstraints = Bool
True
, checkExhaustive :: Bool
checkExhaustive = Bool
False
, checkLeafV3 :: Bool
checkLeafV3 = Bool
True
, checkLeafKeyUsage :: [ExtKeyUsageFlag]
checkLeafKeyUsage = []
, checkLeafKeyPurpose :: [ExtKeyUsagePurpose]
checkLeafKeyPurpose = []
, checkFQHN :: Bool
checkFQHN = Bool
True
}
instance Default ValidationChecks where
def :: ValidationChecks
def = ValidationChecks
defaultChecks
defaultHooks :: ValidationHooks
defaultHooks :: ValidationHooks
defaultHooks = ValidationHooks :: (DistinguishedName -> Certificate -> Bool)
-> (DateTime -> Certificate -> [FailedReason])
-> (String -> Certificate -> [FailedReason])
-> ([FailedReason] -> [FailedReason])
-> ValidationHooks
ValidationHooks
{ hookMatchSubjectIssuer :: DistinguishedName -> Certificate -> Bool
hookMatchSubjectIssuer = DistinguishedName -> Certificate -> Bool
matchSI
, hookValidateTime :: DateTime -> Certificate -> [FailedReason]
hookValidateTime = DateTime -> Certificate -> [FailedReason]
validateTime
, hookValidateName :: String -> Certificate -> [FailedReason]
hookValidateName = String -> Certificate -> [FailedReason]
validateCertificateName
, hookFilterReason :: [FailedReason] -> [FailedReason]
hookFilterReason = [FailedReason] -> [FailedReason]
forall a. a -> a
id
}
instance Default ValidationHooks where
def :: ValidationHooks
def = ValidationHooks
defaultHooks
validateDefault :: CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validateDefault :: CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validateDefault = HashALG
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validate HashALG
HashSHA256 ValidationHooks
defaultHooks ValidationChecks
defaultChecks
validate :: HashALG
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validate :: HashALG
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validate HashALG
_ ValidationHooks
_ ValidationChecks
_ CertificateStore
_ ValidationCache
_ ServiceID
_ (CertificateChain []) = [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason
EmptyChain]
validate HashALG
hashAlg ValidationHooks
hooks ValidationChecks
checks CertificateStore
store ValidationCache
cache ServiceID
ident cc :: CertificateChain
cc@(CertificateChain (SignedExact Certificate
top:[SignedExact Certificate]
_)) = do
ValidationCacheResult
cacheResult <- (ValidationCache -> ValidationCacheQueryCallback
cacheQuery ValidationCache
cache) ServiceID
ident Fingerprint
fingerPrint (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
top)
case ValidationCacheResult
cacheResult of
ValidationCacheResult
ValidationCachePass -> [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return []
ValidationCacheDenied String
s -> [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> FailedReason
CacheSaysNo String
s]
ValidationCacheResult
ValidationCacheUnknown -> do
DateTime
validationTime <- IO DateTime
-> (DateTime -> IO DateTime) -> Maybe DateTime -> IO DateTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Elapsed -> DateTime
forall t1 t2. (Timeable t1, Time t2) => t1 -> t2
timeConvert (Elapsed -> DateTime) -> IO Elapsed -> IO DateTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Elapsed
timeCurrent) DateTime -> IO DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DateTime -> IO DateTime) -> Maybe DateTime -> IO DateTime
forall a b. (a -> b) -> a -> b
$ ValidationChecks -> Maybe DateTime
checkAtTime ValidationChecks
checks
[FailedReason]
failedReasons <- DateTime
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
doValidate DateTime
validationTime ValidationHooks
hooks ValidationChecks
checks CertificateStore
store ServiceID
ident CertificateChain
cc
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FailedReason] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FailedReason]
failedReasons) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (ValidationCache -> ValidationCacheAddCallback
cacheAdd ValidationCache
cache) ServiceID
ident Fingerprint
fingerPrint (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
top)
[FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason]
failedReasons
where fingerPrint :: Fingerprint
fingerPrint = SignedExact Certificate -> HashALG -> Fingerprint
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
getFingerprint SignedExact Certificate
top HashALG
hashAlg
doValidate :: DateTime
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
doValidate :: DateTime
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
doValidate DateTime
_ ValidationHooks
_ ValidationChecks
_ CertificateStore
_ ServiceID
_ (CertificateChain []) = [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason
EmptyChain]
doValidate DateTime
validationTime ValidationHooks
hooks ValidationChecks
checks CertificateStore
store (String
fqhn,ByteString
_) (CertificateChain (SignedExact Certificate
top:[SignedExact Certificate]
rchain)) =
(ValidationHooks -> [FailedReason] -> [FailedReason]
hookFilterReason ValidationHooks
hooks) ([FailedReason] -> [FailedReason])
-> IO [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason]
doLeafChecks IO [FailedReason] -> IO [FailedReason] -> IO [FailedReason]
forall (m :: * -> *).
Monad m =>
m [FailedReason] -> m [FailedReason] -> m [FailedReason]
|> Int
-> SignedExact Certificate
-> [SignedExact Certificate]
-> IO [FailedReason]
doCheckChain Int
0 SignedExact Certificate
top [SignedExact Certificate]
rchain)
where isExhaustive :: Bool
isExhaustive = ValidationChecks -> Bool
checkExhaustive ValidationChecks
checks
m [FailedReason]
a |> :: m [FailedReason] -> m [FailedReason] -> m [FailedReason]
|> m [FailedReason]
b = Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
forall (m :: * -> *).
Monad m =>
Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
exhaustive Bool
isExhaustive m [FailedReason]
a m [FailedReason]
b
doLeafChecks :: [FailedReason]
doLeafChecks = SignedExact Certificate -> [FailedReason]
doNameCheck SignedExact Certificate
top [FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ Certificate -> [FailedReason]
doV3Check Certificate
topCert [FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ Certificate -> [FailedReason]
doKeyUsageCheck Certificate
topCert
where topCert :: Certificate
topCert = SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
top
doCheckChain :: Int -> SignedCertificate -> [SignedCertificate] -> IO [FailedReason]
doCheckChain :: Int
-> SignedExact Certificate
-> [SignedExact Certificate]
-> IO [FailedReason]
doCheckChain Int
level SignedExact Certificate
current [SignedExact Certificate]
chain = do
[FailedReason]
r <- Certificate -> IO [FailedReason]
forall (m :: * -> *). Monad m => Certificate -> m [FailedReason]
doCheckCertificate (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
current)
[FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason]
r IO [FailedReason] -> IO [FailedReason] -> IO [FailedReason]
forall (m :: * -> *).
Monad m =>
m [FailedReason] -> m [FailedReason] -> m [FailedReason]
|> (case DistinguishedName
-> CertificateStore -> Maybe (SignedExact Certificate)
findCertificate (Certificate -> DistinguishedName
certIssuerDN Certificate
cert) CertificateStore
store of
Just SignedExact Certificate
trustedSignedCert -> [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FailedReason] -> IO [FailedReason])
-> [FailedReason] -> IO [FailedReason]
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate
-> SignedExact Certificate -> [FailedReason]
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> SignedExact Certificate -> [FailedReason]
checkSignature SignedExact Certificate
current SignedExact Certificate
trustedSignedCert
Maybe (SignedExact Certificate)
Nothing | Certificate -> Bool
isSelfSigned Certificate
cert -> [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason
SelfSigned] IO [FailedReason] -> IO [FailedReason] -> IO [FailedReason]
forall (m :: * -> *).
Monad m =>
m [FailedReason] -> m [FailedReason] -> m [FailedReason]
|> [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return (SignedExact Certificate
-> SignedExact Certificate -> [FailedReason]
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> SignedExact Certificate -> [FailedReason]
checkSignature SignedExact Certificate
current SignedExact Certificate
current)
| [SignedExact Certificate] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedExact Certificate]
chain -> [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason
UnknownCA]
| Bool
otherwise ->
case DistinguishedName
-> [SignedExact Certificate]
-> Maybe (SignedExact Certificate, [SignedExact Certificate])
findIssuer (Certificate -> DistinguishedName
certIssuerDN Certificate
cert) [SignedExact Certificate]
chain of
Maybe (SignedExact Certificate, [SignedExact Certificate])
Nothing -> [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason
UnknownCA]
Just (SignedExact Certificate
issuer, [SignedExact Certificate]
remaining) ->
[FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Certificate -> [FailedReason]
checkCA Int
level (Certificate -> [FailedReason]) -> Certificate -> [FailedReason]
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
issuer)
IO [FailedReason] -> IO [FailedReason] -> IO [FailedReason]
forall (m :: * -> *).
Monad m =>
m [FailedReason] -> m [FailedReason] -> m [FailedReason]
|> [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return (SignedExact Certificate
-> SignedExact Certificate -> [FailedReason]
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> SignedExact Certificate -> [FailedReason]
checkSignature SignedExact Certificate
current SignedExact Certificate
issuer)
IO [FailedReason] -> IO [FailedReason] -> IO [FailedReason]
forall (m :: * -> *).
Monad m =>
m [FailedReason] -> m [FailedReason] -> m [FailedReason]
|> Int
-> SignedExact Certificate
-> [SignedExact Certificate]
-> IO [FailedReason]
doCheckChain (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) SignedExact Certificate
issuer [SignedExact Certificate]
remaining)
where cert :: Certificate
cert = SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
current
findIssuer :: DistinguishedName
-> [SignedExact Certificate]
-> Maybe (SignedExact Certificate, [SignedExact Certificate])
findIssuer DistinguishedName
issuerDN [SignedExact Certificate]
chain
| ValidationChecks -> Bool
checkStrictOrdering ValidationChecks
checks =
case [SignedExact Certificate]
chain of
[] -> String
-> Maybe (SignedExact Certificate, [SignedExact Certificate])
forall a. HasCallStack => String -> a
error String
"not possible"
(SignedExact Certificate
c:[SignedExact Certificate]
cs) | DistinguishedName -> Certificate -> Bool
matchSubjectIdentifier DistinguishedName
issuerDN (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
c) -> (SignedExact Certificate, [SignedExact Certificate])
-> Maybe (SignedExact Certificate, [SignedExact Certificate])
forall a. a -> Maybe a
Just (SignedExact Certificate
c, [SignedExact Certificate]
cs)
| Bool
otherwise -> Maybe (SignedExact Certificate, [SignedExact Certificate])
forall a. Maybe a
Nothing
| Bool
otherwise =
(\SignedExact Certificate
x -> (SignedExact Certificate
x, (SignedExact Certificate -> Bool)
-> [SignedExact Certificate] -> [SignedExact Certificate]
forall a. (a -> Bool) -> [a] -> [a]
filter (SignedExact Certificate -> SignedExact Certificate -> Bool
forall a. Eq a => a -> a -> Bool
/= SignedExact Certificate
x) [SignedExact Certificate]
chain)) (SignedExact Certificate
-> (SignedExact Certificate, [SignedExact Certificate]))
-> Maybe (SignedExact Certificate)
-> Maybe (SignedExact Certificate, [SignedExact Certificate])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (SignedExact Certificate -> Bool)
-> [SignedExact Certificate] -> Maybe (SignedExact Certificate)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (DistinguishedName -> Certificate -> Bool
matchSubjectIdentifier DistinguishedName
issuerDN (Certificate -> Bool)
-> (SignedExact Certificate -> Certificate)
-> SignedExact Certificate
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedExact Certificate -> Certificate
getCertificate) [SignedExact Certificate]
chain
matchSubjectIdentifier :: DistinguishedName -> Certificate -> Bool
matchSubjectIdentifier = ValidationHooks -> DistinguishedName -> Certificate -> Bool
hookMatchSubjectIssuer ValidationHooks
hooks
checkCA :: Int -> Certificate -> [FailedReason]
checkCA :: Int -> Certificate -> [FailedReason]
checkCA Int
level Certificate
cert
| Bool -> Bool
not (ValidationChecks -> Bool
checkCAConstraints ValidationChecks
checks) = []
| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool
allowedSign,Bool
allowedCA,Bool
allowedDepth] = []
| Bool
otherwise = (if Bool
allowedSign then [] else [FailedReason
NotAllowedToSign])
[FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ (if Bool
allowedCA then [] else [FailedReason
NotAnAuthority])
[FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ (if Bool
allowedDepth then [] else [FailedReason
AuthorityTooDeep])
where extensions :: Extensions
extensions = Certificate -> Extensions
certExtensions Certificate
cert
allowedSign :: Bool
allowedSign = case Extensions -> Maybe ExtKeyUsage
forall a. Extension a => Extensions -> Maybe a
extensionGet Extensions
extensions of
Just (ExtKeyUsage [ExtKeyUsageFlag]
flags) -> ExtKeyUsageFlag
KeyUsage_keyCertSign ExtKeyUsageFlag -> [ExtKeyUsageFlag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtKeyUsageFlag]
flags
Maybe ExtKeyUsage
Nothing -> Bool
True
(Bool
allowedCA,Maybe Integer
pathLen) = case Extensions -> Maybe ExtBasicConstraints
forall a. Extension a => Extensions -> Maybe a
extensionGet Extensions
extensions of
Just (ExtBasicConstraints Bool
True Maybe Integer
pl) -> (Bool
True, Maybe Integer
pl)
Maybe ExtBasicConstraints
_ -> (Bool
False, Maybe Integer
forall a. Maybe a
Nothing)
allowedDepth :: Bool
allowedDepth = case Maybe Integer
pathLen of
Maybe Integer
Nothing -> Bool
True
Just Integer
pl | Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
level -> Bool
True
| Bool
otherwise -> Bool
False
doNameCheck :: SignedExact Certificate -> [FailedReason]
doNameCheck SignedExact Certificate
cert
| Bool -> Bool
not (ValidationChecks -> Bool
checkFQHN ValidationChecks
checks) = []
| Bool
otherwise = (ValidationHooks -> String -> Certificate -> [FailedReason]
hookValidateName ValidationHooks
hooks) String
fqhn (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
cert)
doV3Check :: Certificate -> [FailedReason]
doV3Check Certificate
cert
| ValidationChecks -> Bool
checkLeafV3 ValidationChecks
checks = case Certificate -> Int
certVersion Certificate
cert of
Int
2 -> []
Int
_ -> [FailedReason
LeafNotV3]
| Bool
otherwise = []
doKeyUsageCheck :: Certificate -> [FailedReason]
doKeyUsageCheck Certificate
cert =
Maybe [ExtKeyUsageFlag]
-> [ExtKeyUsageFlag] -> FailedReason -> [FailedReason]
forall a a. Eq a => Maybe [a] -> [a] -> a -> [a]
compareListIfExistAndNotNull Maybe [ExtKeyUsageFlag]
mflags (ValidationChecks -> [ExtKeyUsageFlag]
checkLeafKeyUsage ValidationChecks
checks) FailedReason
LeafKeyUsageNotAllowed
[FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ Maybe [ExtKeyUsagePurpose]
-> [ExtKeyUsagePurpose] -> FailedReason -> [FailedReason]
forall a a. Eq a => Maybe [a] -> [a] -> a -> [a]
compareListIfExistAndNotNull Maybe [ExtKeyUsagePurpose]
mpurposes (ValidationChecks -> [ExtKeyUsagePurpose]
checkLeafKeyPurpose ValidationChecks
checks) FailedReason
LeafKeyPurposeNotAllowed
where mflags :: Maybe [ExtKeyUsageFlag]
mflags = case Extensions -> Maybe ExtKeyUsage
forall a. Extension a => Extensions -> Maybe a
extensionGet (Extensions -> Maybe ExtKeyUsage)
-> Extensions -> Maybe ExtKeyUsage
forall a b. (a -> b) -> a -> b
$ Certificate -> Extensions
certExtensions Certificate
cert of
Just (ExtKeyUsage [ExtKeyUsageFlag]
keyflags) -> [ExtKeyUsageFlag] -> Maybe [ExtKeyUsageFlag]
forall a. a -> Maybe a
Just [ExtKeyUsageFlag]
keyflags
Maybe ExtKeyUsage
Nothing -> Maybe [ExtKeyUsageFlag]
forall a. Maybe a
Nothing
mpurposes :: Maybe [ExtKeyUsagePurpose]
mpurposes = case Extensions -> Maybe ExtExtendedKeyUsage
forall a. Extension a => Extensions -> Maybe a
extensionGet (Extensions -> Maybe ExtExtendedKeyUsage)
-> Extensions -> Maybe ExtExtendedKeyUsage
forall a b. (a -> b) -> a -> b
$ Certificate -> Extensions
certExtensions Certificate
cert of
Just (ExtExtendedKeyUsage [ExtKeyUsagePurpose]
keyPurposes) -> [ExtKeyUsagePurpose] -> Maybe [ExtKeyUsagePurpose]
forall a. a -> Maybe a
Just [ExtKeyUsagePurpose]
keyPurposes
Maybe ExtExtendedKeyUsage
Nothing -> Maybe [ExtKeyUsagePurpose]
forall a. Maybe a
Nothing
compareListIfExistAndNotNull :: Maybe [a] -> [a] -> a -> [a]
compareListIfExistAndNotNull Maybe [a]
Nothing [a]
_ a
_ = []
compareListIfExistAndNotNull (Just [a]
list) [a]
expected a
err
| [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
expected = []
| [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
intersect [a]
expected [a]
list [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
expected = []
| Bool
otherwise = [a
err]
doCheckCertificate :: Certificate -> m [FailedReason]
doCheckCertificate Certificate
cert =
Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
forall (m :: * -> *).
Monad m =>
Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
exhaustiveList (ValidationChecks -> Bool
checkExhaustive ValidationChecks
checks)
[ (ValidationChecks -> Bool
checkTimeValidity ValidationChecks
checks, [FailedReason] -> m [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return ((ValidationHooks -> DateTime -> Certificate -> [FailedReason]
hookValidateTime ValidationHooks
hooks) DateTime
validationTime Certificate
cert))
]
isSelfSigned :: Certificate -> Bool
isSelfSigned :: Certificate -> Bool
isSelfSigned Certificate
cert = Certificate -> DistinguishedName
certSubjectDN Certificate
cert DistinguishedName -> DistinguishedName -> Bool
forall a. Eq a => a -> a -> Bool
== Certificate -> DistinguishedName
certIssuerDN Certificate
cert
checkSignature :: SignedExact a -> SignedExact Certificate -> [FailedReason]
checkSignature SignedExact a
signedCert SignedExact Certificate
signingCert =
case SignedExact a -> PubKey -> SignatureVerification
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> PubKey -> SignatureVerification
verifySignedSignature SignedExact a
signedCert (Certificate -> PubKey
certPubKey (Certificate -> PubKey) -> Certificate -> PubKey
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
signingCert) of
SignatureVerification
SignaturePass -> []
SignatureFailed SignatureFailure
r -> [SignatureFailure -> FailedReason
InvalidSignature SignatureFailure
r]
validateTime :: DateTime -> Certificate -> [FailedReason]
validateTime :: DateTime -> Certificate -> [FailedReason]
validateTime DateTime
currentTime Certificate
cert
| DateTime
currentTime DateTime -> DateTime -> Bool
forall a. Ord a => a -> a -> Bool
< DateTime
before = [FailedReason
InFuture]
| DateTime
currentTime DateTime -> DateTime -> Bool
forall a. Ord a => a -> a -> Bool
> DateTime
after = [FailedReason
Expired]
| Bool
otherwise = []
where (DateTime
before, DateTime
after) = Certificate -> (DateTime, DateTime)
certValidity Certificate
cert
getNames :: Certificate -> (Maybe String, [String])
getNames :: Certificate -> (Maybe String, [String])
getNames Certificate
cert = (Maybe ASN1CharacterString
commonName Maybe ASN1CharacterString
-> (ASN1CharacterString -> Maybe String) -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ASN1CharacterString -> Maybe String
asn1CharacterToString, [String]
altNames)
where commonName :: Maybe ASN1CharacterString
commonName = DnElement -> DistinguishedName -> Maybe ASN1CharacterString
getDnElement DnElement
DnCommonName (DistinguishedName -> Maybe ASN1CharacterString)
-> DistinguishedName -> Maybe ASN1CharacterString
forall a b. (a -> b) -> a -> b
$ Certificate -> DistinguishedName
certSubjectDN Certificate
cert
altNames :: [String]
altNames = [String]
-> (ExtSubjectAltName -> [String])
-> Maybe ExtSubjectAltName
-> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ExtSubjectAltName -> [String]
toAltName (Maybe ExtSubjectAltName -> [String])
-> Maybe ExtSubjectAltName -> [String]
forall a b. (a -> b) -> a -> b
$ Extensions -> Maybe ExtSubjectAltName
forall a. Extension a => Extensions -> Maybe a
extensionGet (Extensions -> Maybe ExtSubjectAltName)
-> Extensions -> Maybe ExtSubjectAltName
forall a b. (a -> b) -> a -> b
$ Certificate -> Extensions
certExtensions Certificate
cert
toAltName :: ExtSubjectAltName -> [String]
toAltName (ExtSubjectAltName [AltName]
names) = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall a b. (a -> b) -> a -> b
$ (AltName -> Maybe String) -> [AltName] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map AltName -> Maybe String
unAltName [AltName]
names
where unAltName :: AltName -> Maybe String
unAltName (AltNameDNS String
s) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
unAltName AltName
_ = Maybe String
forall a. Maybe a
Nothing
validateCertificateName :: HostName -> Certificate -> [FailedReason]
validateCertificateName :: String -> Certificate -> [FailedReason]
validateCertificateName String
fqhn Certificate
cert
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
altNames =
[FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch [] ([[FailedReason]] -> [FailedReason])
-> [[FailedReason]] -> [FailedReason]
forall a b. (a -> b) -> a -> b
$ (String -> [FailedReason]) -> [String] -> [[FailedReason]]
forall a b. (a -> b) -> [a] -> [b]
map String -> [FailedReason]
matchDomain [String]
altNames
| Bool
otherwise =
case Maybe String
commonName of
Maybe String
Nothing -> [FailedReason
NoCommonName]
Just String
cn -> [FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch [] ([[FailedReason]] -> [FailedReason])
-> [[FailedReason]] -> [FailedReason]
forall a b. (a -> b) -> a -> b
$ [String -> [FailedReason]
matchDomain String
cn]
where (Maybe String
commonName, [String]
altNames) = Certificate -> (Maybe String, [String])
getNames Certificate
cert
findMatch :: [FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch :: [FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch [FailedReason]
_ [] = [String -> FailedReason
NameMismatch String
fqhn]
findMatch [FailedReason]
_ ([]:[[FailedReason]]
_) = []
findMatch [FailedReason]
acc ([FailedReason]
_ :[[FailedReason]]
xs) = [FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch [FailedReason]
acc [[FailedReason]]
xs
matchDomain :: String -> [FailedReason]
matchDomain :: String -> [FailedReason]
matchDomain String
name = case String -> [String]
splitDot String
name of
[String]
l | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"") [String]
l -> [String -> FailedReason
InvalidName String
name]
| [String] -> String
forall a. [a] -> a
head [String]
l String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"*" -> [String] -> [FailedReason]
wildcardMatch (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
l)
| [String]
l [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== String -> [String]
splitDot String
fqhn -> []
| Bool
otherwise -> [String -> FailedReason
NameMismatch String
fqhn]
wildcardMatch :: [String] -> [FailedReason]
wildcardMatch [String]
l
| [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
l = [FailedReason
InvalidWildcard]
| [String]
l [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 (String -> [String]
splitDot String
fqhn) = []
| Bool
otherwise = [String -> FailedReason
NameMismatch String
fqhn]
splitDot :: String -> [String]
splitDot :: String -> [String]
splitDot [] = [String
""]
splitDot String
x =
let (String
y, String
z) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
x in
(Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
y String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (if String
z String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then [] else String -> [String]
splitDot (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
z)
matchSI :: DistinguishedName -> Certificate -> Bool
matchSI :: DistinguishedName -> Certificate -> Bool
matchSI DistinguishedName
issuerDN Certificate
issuer = Certificate -> DistinguishedName
certSubjectDN Certificate
issuer DistinguishedName -> DistinguishedName -> Bool
forall a. Eq a => a -> a -> Bool
== DistinguishedName
issuerDN
exhaustive :: Monad m => Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
exhaustive :: Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
exhaustive Bool
isExhaustive m [FailedReason]
f1 m [FailedReason]
f2 = m [FailedReason]
f1 m [FailedReason]
-> ([FailedReason] -> m [FailedReason]) -> m [FailedReason]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [FailedReason] -> m [FailedReason]
cont
where cont :: [FailedReason] -> m [FailedReason]
cont [FailedReason]
l1
| [FailedReason] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FailedReason]
l1 = m [FailedReason]
f2
| Bool
isExhaustive = m [FailedReason]
f2 m [FailedReason]
-> ([FailedReason] -> m [FailedReason]) -> m [FailedReason]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[FailedReason]
l2 -> [FailedReason] -> m [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FailedReason]
l1 [FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ [FailedReason]
l2)
| Bool
otherwise = [FailedReason] -> m [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason]
l1
exhaustiveList :: Monad m => Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
exhaustiveList :: Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
exhaustiveList Bool
_ [] = [FailedReason] -> m [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return []
exhaustiveList Bool
isExhaustive ((Bool
performCheck,m [FailedReason]
c):[(Bool, m [FailedReason])]
cs)
| Bool
performCheck = Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
forall (m :: * -> *).
Monad m =>
Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
exhaustive Bool
isExhaustive m [FailedReason]
c (Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
forall (m :: * -> *).
Monad m =>
Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
exhaustiveList Bool
isExhaustive [(Bool, m [FailedReason])]
cs)
| Bool
otherwise = Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
forall (m :: * -> *).
Monad m =>
Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
exhaustiveList Bool
isExhaustive [(Bool, m [FailedReason])]
cs