-- |
-- Module      : Data.X509.Validation
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- X.509 Certificate checks and validations routines
--
-- Follows RFC5280 / RFC6818
--
module Data.X509.Validation
    (
      module Data.X509.Validation.Types
    , Fingerprint(..)
    -- * Failed validation types
    , FailedReason(..)
    , SignatureFailure(..)
    -- * Validation configuration types
    , ValidationChecks(..)
    , ValidationHooks(..)
    , defaultChecks
    , defaultHooks
    -- * Validation
    , validate
    , validatePure
    , validateDefault
    , getFingerprint
    -- * Cache
    , module Data.X509.Validation.Cache
    -- * Signature verification
    , 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

-- | Possible reason of certificate and chain failure.
--
-- The values 'InvalidName' and 'InvalidWildcard' are internal-only and are
-- never returned by the validation functions.  'NameMismatch' is returned
-- instead.
data FailedReason =
      UnknownCriticalExtension -- ^ certificate contains an unknown critical extension
    | Expired                  -- ^ validity ends before checking time
    | InFuture                 -- ^ validity starts after checking time
    | SelfSigned               -- ^ certificate is self signed
    | UnknownCA                -- ^ unknown Certificate Authority (CA)
    | NotAllowedToSign         -- ^ certificate is not allowed to sign
    | NotAnAuthority           -- ^ not a CA
    | AuthorityTooDeep         -- ^ Violation of the optional Basic constraint's path length
    | NoCommonName             -- ^ Certificate doesn't have any common name (CN)
    | InvalidName String       -- ^ Invalid name in certificate
    | NameMismatch String      -- ^ connection name and certificate do not match
    | InvalidWildcard          -- ^ invalid wildcard in certificate
    | LeafKeyUsageNotAllowed   -- ^ the requested key usage is not compatible with the leaf certificate's key usage
    | LeafKeyPurposeNotAllowed -- ^ the requested key purpose is not compatible with the leaf certificate's extended key usage
    | LeafNotV3                -- ^ Only authorized an X509.V3 certificate as leaf certificate.
    | EmptyChain               -- ^ empty chain of certificate
    | CacheSaysNo String       -- ^ the cache explicitely denied this certificate
    | InvalidSignature SignatureFailure -- ^ signature failed
    deriving (Int -> FailedReason -> ShowS
[FailedReason] -> ShowS
FailedReason -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FailedReason] -> ShowS
$cshowList :: [FailedReason] -> ShowS
show :: FailedReason -> [Char]
$cshow :: FailedReason -> [Char]
showsPrec :: Int -> FailedReason -> ShowS
$cshowsPrec :: Int -> FailedReason -> ShowS
Show,FailedReason -> FailedReason -> Bool
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)

-- | A set of checks to activate or parametrize to perform on certificates.
--
-- It's recommended to use 'defaultChecks' to create the structure,
-- to better cope with future changes or expansion of the structure.
data ValidationChecks = ValidationChecks
    {
    -- | check time validity of every certificate in the chain.
    -- the make sure that current time is between each validity bounds
    -- in the certificate
      ValidationChecks -> Bool
checkTimeValidity   :: Bool
    -- | The time when the validity check happens. When set to Nothing,
    -- the current time will be used
    , ValidationChecks -> Maybe DateTime
checkAtTime         :: Maybe DateTime
    -- | Check that no certificate is included that shouldn't be included.
    -- unfortunately despite the specification violation, a lots of
    -- real world server serves useless and usually old certificates
    -- that are not relevant to the certificate sent, in their chain.
    , ValidationChecks -> Bool
checkStrictOrdering :: Bool
    -- | Check that signing certificate got the CA basic constraint.
    -- this is absolutely not recommended to turn it off.
    , ValidationChecks -> Bool
checkCAConstraints  :: Bool
    -- | Check the whole certificate chain without stopping at the first failure.
    -- Allow gathering a exhaustive list of failure reasons. if this is
    -- turn off, it's absolutely not safe to ignore a failed reason even it doesn't look serious
    -- (e.g. Expired) as other more serious checks would not have been performed.
    , ValidationChecks -> Bool
checkExhaustive     :: Bool
    -- | Check that the leaf certificate is version 3. If disable, version 2 certificate
    -- is authorized in leaf position and key usage cannot be checked.
    , ValidationChecks -> Bool
checkLeafV3         :: Bool
    -- | Check that the leaf certificate is authorized to be used for certain usage.
    -- If set to empty list no check are performed, otherwise all the flags is the list
    -- need to exists in the key usage extension. If the extension is not present,
    -- the check will pass and behave as if the certificate key is not restricted to
    -- any specific usage.
    , ValidationChecks -> [ExtKeyUsageFlag]
checkLeafKeyUsage   :: [ExtKeyUsageFlag]
    -- | Check that the leaf certificate is authorized to be used for certain purpose.
    -- If set to empty list no check are performed, otherwise all the flags is the list
    -- need to exists in the extended key usage extension if present. If the extension is not
    -- present, then the check will pass and behave as if the certificate is not restricted
    -- to any specific purpose.
    , ValidationChecks -> [ExtKeyUsagePurpose]
checkLeafKeyPurpose :: [ExtKeyUsagePurpose]
    -- | Check the top certificate names matching the fully qualified hostname (FQHN).
    -- it's not recommended to turn this check off, if no other name checks are performed.
    , ValidationChecks -> Bool
checkFQHN           :: Bool
    } deriving (Int -> ValidationChecks -> ShowS
[ValidationChecks] -> ShowS
ValidationChecks -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ValidationChecks] -> ShowS
$cshowList :: [ValidationChecks] -> ShowS
show :: ValidationChecks -> [Char]
$cshow :: ValidationChecks -> [Char]
showsPrec :: Int -> ValidationChecks -> ShowS
$cshowsPrec :: Int -> ValidationChecks -> ShowS
Show,ValidationChecks -> ValidationChecks -> Bool
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)

-- | A set of hooks to manipulate the way the verification works.
--
-- BEWARE, it's easy to change behavior leading to compromised security.
data ValidationHooks = ValidationHooks
    {
    -- | check whether a given issuer 'DistinguishedName' matches the subject
    -- 'DistinguishedName' of a candidate issuer certificate.
      ValidationHooks -> DistinguishedName -> Certificate -> Bool
hookMatchSubjectIssuer :: DistinguishedName -> Certificate -> Bool
    -- | check whether the certificate in the second argument is valid at the
    -- time provided in the first argument.  Return an empty list for success
    -- or else one or more failure reasons.
    , ValidationHooks -> DateTime -> Certificate -> [FailedReason]
hookValidateTime       :: DateTime -> Certificate -> [FailedReason]
    -- | validate the certificate leaf name with the DNS named used to connect
    , ValidationHooks -> [Char] -> Certificate -> [FailedReason]
hookValidateName       :: HostName -> Certificate -> [FailedReason]
    -- | user filter to modify the list of failure reasons
    , ValidationHooks -> [FailedReason] -> [FailedReason]
hookFilterReason       :: [FailedReason] -> [FailedReason]
    }

-- | Default checks to perform
--
-- The default checks are:
-- * Each certificate time is valid
-- * CA constraints is enforced for signing certificate
-- * Leaf certificate is X.509 v3
-- * Check that the FQHN match
defaultChecks :: ValidationChecks
defaultChecks :: ValidationChecks
defaultChecks = ValidationChecks
    { checkTimeValidity :: Bool
checkTimeValidity   = Bool
True
    , checkAtTime :: Maybe DateTime
checkAtTime         = 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

-- | Default hooks in the validation process
defaultHooks :: ValidationHooks
defaultHooks :: ValidationHooks
defaultHooks = ValidationHooks
    { hookMatchSubjectIssuer :: DistinguishedName -> Certificate -> Bool
hookMatchSubjectIssuer = DistinguishedName -> Certificate -> Bool
matchSI
    , hookValidateTime :: DateTime -> Certificate -> [FailedReason]
hookValidateTime       = DateTime -> Certificate -> [FailedReason]
validateTime
    , hookValidateName :: [Char] -> Certificate -> [FailedReason]
hookValidateName       = [Char] -> Certificate -> [FailedReason]
validateCertificateName
    , hookFilterReason :: [FailedReason] -> [FailedReason]
hookFilterReason       = forall a. a -> a
id
    }

instance Default ValidationHooks where
    def :: ValidationHooks
def = ValidationHooks
defaultHooks

-- | Validate using the default hooks and checks and the SHA256 mechanism as hashing mechanism
validateDefault :: CertificateStore  -- ^ The trusted certificate store for CA
                -> ValidationCache   -- ^ the validation cache callbacks
                -> ServiceID         -- ^ identification of the connection
                -> CertificateChain  -- ^ the certificate chain we want to validate
                -> IO [FailedReason] -- ^ the return failed reasons (empty list is no failure)
validateDefault :: CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validateDefault = HashALG
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validate HashALG
HashSHA256 ValidationHooks
defaultHooks ValidationChecks
defaultChecks

-- | X509 validation
--
-- the function first interrogate the cache and if the validation fail,
-- proper verification is done. If the verification pass, the
-- add to cache callback is called.
validate :: HashALG           -- ^ the hash algorithm we want to use for hashing the leaf certificate
         -> ValidationHooks   -- ^ Hooks to use
         -> ValidationChecks  -- ^ Checks to do
         -> CertificateStore  -- ^ The trusted certificate store for CA
         -> ValidationCache   -- ^ the validation cache callbacks
         -> ServiceID         -- ^ identification of the connection
         -> CertificateChain  -- ^ the certificate chain we want to validate
         -> IO [FailedReason] -- ^ the return failed reasons (empty list is no failure)
validate :: HashALG
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validate HashALG
_ ValidationHooks
_ ValidationChecks
_ CertificateStore
_ ValidationCache
_ ServiceID
_ (CertificateChain []) = 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     -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        ValidationCacheDenied [Char]
s -> forall (m :: * -> *) a. Monad m => a -> m a
return [[Char] -> FailedReason
CacheSaysNo [Char]
s]
        ValidationCacheResult
ValidationCacheUnknown  -> do
            DateTime
validationTime <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall t1 t2. (Timeable t1, Time t2) => t1 -> t2
timeConvert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Elapsed
timeCurrent) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ValidationChecks -> Maybe DateTime
checkAtTime ValidationChecks
checks
            let failedReasons :: [FailedReason]
failedReasons = DateTime
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ServiceID
-> CertificateChain
-> [FailedReason]
validatePure DateTime
validationTime ValidationHooks
hooks ValidationChecks
checks CertificateStore
store ServiceID
ident CertificateChain
cc
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FailedReason]
failedReasons) forall a b. (a -> b) -> a -> b
$ (ValidationCache -> ValidationCacheAddCallback
cacheAdd ValidationCache
cache) ServiceID
ident Fingerprint
fingerPrint (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
top)
            forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason]
failedReasons
  where fingerPrint :: Fingerprint
fingerPrint = forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
getFingerprint SignedExact Certificate
top HashALG
hashAlg


-- | Validate a certificate chain with explicit pure parameters
validatePure :: DateTime         -- ^ The time for which to check validity for
             -> ValidationHooks  -- ^ Hooks to use
             -> ValidationChecks -- ^ Checks to do
             -> CertificateStore -- ^ The trusted certificate store for CA
             -> ServiceID        -- ^ Identification of the connection
             -> CertificateChain -- ^ The certificate chain we want to validate
             -> [FailedReason]   -- ^ the return failed reasons (empty list is no failure)
validatePure :: DateTime
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ServiceID
-> CertificateChain
-> [FailedReason]
validatePure DateTime
_              ValidationHooks
_     ValidationChecks
_      CertificateStore
_     ServiceID
_        (CertificateChain [])           = [FailedReason
EmptyChain]
validatePure DateTime
validationTime ValidationHooks
hooks ValidationChecks
checks CertificateStore
store ([Char]
fqhn,ByteString
_) (CertificateChain (SignedExact Certificate
top:[SignedExact Certificate]
rchain)) =
   ValidationHooks -> [FailedReason] -> [FailedReason]
hookFilterReason ValidationHooks
hooks ([FailedReason]
doLeafChecks [FailedReason] -> [FailedReason] -> [FailedReason]
|> Int
-> SignedExact Certificate
-> [SignedExact Certificate]
-> [FailedReason]
doCheckChain Int
0 SignedExact Certificate
top [SignedExact Certificate]
rchain)
  where isExhaustive :: Bool
isExhaustive = ValidationChecks -> Bool
checkExhaustive ValidationChecks
checks
        [FailedReason]
a |> :: [FailedReason] -> [FailedReason] -> [FailedReason]
|> [FailedReason]
b = Bool -> [FailedReason] -> [FailedReason] -> [FailedReason]
exhaustive Bool
isExhaustive [FailedReason]
a [FailedReason]
b

        doLeafChecks :: [FailedReason]
doLeafChecks = SignedExact Certificate -> [FailedReason]
doNameCheck SignedExact Certificate
top forall a. [a] -> [a] -> [a]
++ Certificate -> [FailedReason]
doV3Check Certificate
topCert 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] -> [FailedReason]
        doCheckChain :: Int
-> SignedExact Certificate
-> [SignedExact Certificate]
-> [FailedReason]
doCheckChain Int
level SignedExact Certificate
current [SignedExact Certificate]
chain =
            Certificate -> [FailedReason]
doCheckCertificate (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
current)
            -- check if we have a trusted certificate in the store belonging to this issuer.
            [FailedReason] -> [FailedReason] -> [FailedReason]
|> (case DistinguishedName
-> CertificateStore -> Maybe (SignedExact Certificate)
findCertificate (Certificate -> DistinguishedName
certIssuerDN Certificate
cert) CertificateStore
store of
                Just SignedExact Certificate
trustedSignedCert      -> 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
SelfSigned] [FailedReason] -> [FailedReason] -> [FailedReason]
|> forall {a}.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> SignedExact Certificate -> [FailedReason]
checkSignature SignedExact Certificate
current SignedExact Certificate
current
                        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedExact Certificate]
chain        -> [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
UnknownCA]
                                Just (SignedExact Certificate
issuer, [SignedExact Certificate]
remaining) ->
                                    Int -> Certificate -> [FailedReason]
checkCA Int
level (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
issuer)
                                    [FailedReason] -> [FailedReason] -> [FailedReason]
|> forall {a}.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> SignedExact Certificate -> [FailedReason]
checkSignature SignedExact Certificate
current SignedExact Certificate
issuer
                                    [FailedReason] -> [FailedReason] -> [FailedReason]
|> Int
-> SignedExact Certificate
-> [SignedExact Certificate]
-> [FailedReason]
doCheckChain (Int
levelforall 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
        -- in a strict ordering check the next certificate has to be the issuer.
        -- otherwise we dynamically reorder the chain to have the necessary certificate
        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
                    []     -> forall a. HasCallStack => [Char] -> a
error [Char]
"not possible"
                    (SignedExact Certificate
c:[SignedExact Certificate]
cs) | DistinguishedName -> Certificate -> Bool
matchSubjectIdentifier DistinguishedName
issuerDN (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
c) -> forall a. a -> Maybe a
Just (SignedExact Certificate
c, [SignedExact Certificate]
cs)
                           | Bool
otherwise                                          -> forall a. Maybe a
Nothing
            | Bool
otherwise =
                (\SignedExact Certificate
x -> (SignedExact Certificate
x, forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= SignedExact Certificate
x) [SignedExact Certificate]
chain)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (DistinguishedName -> Certificate -> Bool
matchSubjectIdentifier DistinguishedName
issuerDN 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

        -- we check here that the certificate is allowed to be a certificate
        -- authority, by checking the BasicConstraint extension. We also check,
        -- if present the key usage extension for ability to cert sign. If this
        -- extension is not present, then according to RFC 5280, it's safe to
        -- assume that only cert sign (and crl sign) are allowed by this certificate.
        checkCA :: Int -> Certificate -> [FailedReason]
        checkCA :: Int -> Certificate -> [FailedReason]
checkCA Int
level Certificate
cert
            | Bool -> Bool
not (ValidationChecks -> Bool
checkCAConstraints ValidationChecks
checks)          = []
            | forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool
allowedSign,Bool
allowedCA,Bool
allowedDepth] = []
            | Bool
otherwise = (if Bool
allowedSign then [] else [FailedReason
NotAllowedToSign])
                       forall a. [a] -> [a] -> [a]
++ (if Bool
allowedCA   then [] else [FailedReason
NotAnAuthority])
                       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 forall a. Extension a => Extensions -> Maybe a
extensionGet Extensions
extensions of
                                Just (ExtKeyUsage [ExtKeyUsageFlag]
flags) -> ExtKeyUsageFlag
KeyUsage_keyCertSign 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 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, forall a. Maybe a
Nothing)
                allowedDepth :: Bool
allowedDepth = case Maybe Integer
pathLen of
                                    Maybe Integer
Nothing                            -> Bool
True
                                    Just Integer
pl | forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pl 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 -> [Char] -> Certificate -> [FailedReason]
hookValidateName ValidationHooks
hooks) [Char]
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 {- confusingly it means X509.V3 -} -> []
                                        Int
_ -> [FailedReason
LeafNotV3]
            | Bool
otherwise = []

        doKeyUsageCheck :: Certificate -> [FailedReason]
doKeyUsageCheck Certificate
cert =
               forall {a} {a}. Eq a => Maybe [a] -> [a] -> a -> [a]
compareListIfExistAndNotNull Maybe [ExtKeyUsageFlag]
mflags (ValidationChecks -> [ExtKeyUsageFlag]
checkLeafKeyUsage ValidationChecks
checks) FailedReason
LeafKeyUsageNotAllowed
            forall a. [a] -> [a] -> [a]
++ 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 forall a. Extension a => Extensions -> Maybe a
extensionGet forall a b. (a -> b) -> a -> b
$ Certificate -> Extensions
certExtensions Certificate
cert of
                            Just (ExtKeyUsage [ExtKeyUsageFlag]
keyflags) -> forall a. a -> Maybe a
Just [ExtKeyUsageFlag]
keyflags
                            Maybe ExtKeyUsage
Nothing                     -> forall a. Maybe a
Nothing
                mpurposes :: Maybe [ExtKeyUsagePurpose]
mpurposes = case forall a. Extension a => Extensions -> Maybe a
extensionGet forall a b. (a -> b) -> a -> b
$ Certificate -> Extensions
certExtensions Certificate
cert of
                            Just (ExtExtendedKeyUsage [ExtKeyUsagePurpose]
keyPurposes) -> forall a. a -> Maybe a
Just [ExtKeyUsagePurpose]
keyPurposes
                            Maybe ExtExtendedKeyUsage
Nothing                                -> forall a. Maybe a
Nothing
                -- compare a list of things to an expected list. the expected list
                -- need to be a subset of the list (if not Nothing), and is not will
                -- return [err]
                compareListIfExistAndNotNull :: Maybe [a] -> [a] -> a -> [a]
compareListIfExistAndNotNull Maybe [a]
Nothing     [a]
_        a
_   = []
                compareListIfExistAndNotNull (Just [a]
list) [a]
expected a
err
                    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
expected                       = []
                    | forall a. Eq a => [a] -> [a] -> [a]
intersect [a]
expected [a]
list forall a. Eq a => a -> a -> Bool
== [a]
expected = []
                    | Bool
otherwise                           = [a
err]

        doCheckCertificate :: Certificate -> [FailedReason]
doCheckCertificate Certificate
cert =
            Bool -> [(Bool, [FailedReason])] -> [FailedReason]
exhaustiveList (ValidationChecks -> Bool
checkExhaustive ValidationChecks
checks)
                [ (ValidationChecks -> Bool
checkTimeValidity ValidationChecks
checks, 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 forall a. Eq a => a -> a -> Bool
== Certificate -> DistinguishedName
certIssuerDN Certificate
cert

        -- check signature of 'signedCert' against the 'signingCert'
        checkSignature :: SignedExact a -> SignedExact Certificate -> [FailedReason]
checkSignature SignedExact a
signedCert SignedExact Certificate
signingCert =
            case forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> PubKey -> SignatureVerification
verifySignedSignature SignedExact a
signedCert (Certificate -> PubKey
certPubKey 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]

-- | Validate that the current time is between validity bounds
validateTime :: DateTime -> Certificate -> [FailedReason]
validateTime :: DateTime -> Certificate -> [FailedReason]
validateTime DateTime
currentTime Certificate
cert
    | DateTime
currentTime forall a. Ord a => a -> a -> Bool
< DateTime
before = [FailedReason
InFuture]
    | DateTime
currentTime 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 [Char], [[Char]])
getNames Certificate
cert = (Maybe ASN1CharacterString
commonName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ASN1CharacterString -> Maybe [Char]
asn1CharacterToString, [[Char]]
altNames)
  where commonName :: Maybe ASN1CharacterString
commonName = DnElement -> DistinguishedName -> Maybe ASN1CharacterString
getDnElement DnElement
DnCommonName forall a b. (a -> b) -> a -> b
$ Certificate -> DistinguishedName
certSubjectDN Certificate
cert
        altNames :: [[Char]]
altNames   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ExtSubjectAltName -> [[Char]]
toAltName forall a b. (a -> b) -> a -> b
$ forall a. Extension a => Extensions -> Maybe a
extensionGet forall a b. (a -> b) -> a -> b
$ Certificate -> Extensions
certExtensions Certificate
cert
        toAltName :: ExtSubjectAltName -> [[Char]]
toAltName (ExtSubjectAltName [AltName]
names) = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AltName -> Maybe [Char]
unAltName [AltName]
names
            where unAltName :: AltName -> Maybe [Char]
unAltName (AltNameDNS [Char]
s) = forall a. a -> Maybe a
Just [Char]
s
                  unAltName AltName
_              = forall a. Maybe a
Nothing

-- | Validate that the fqhn is matched by at least one name in the certificate.
-- If the subjectAltname extension is present, then the certificate commonName
-- is ignored, and only the DNS names, if any, in the subjectAltName are
-- considered.  Otherwise, the commonName from the subjectDN is used.
--
-- Note that DNS names in the subjectAltName are in IDNA A-label form. If the
-- destination hostname is a UTF-8 name, it must be provided to the TLS context
-- in (non-transitional) IDNA2008 A-label form.
validateCertificateName :: HostName -> Certificate -> [FailedReason]
validateCertificateName :: [Char] -> Certificate -> [FailedReason]
validateCertificateName [Char]
fqhn Certificate
cert
    | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
altNames =
        [FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [FailedReason]
matchDomain [[Char]]
altNames
    | Bool
otherwise =
        case Maybe [Char]
commonName of
            Maybe [Char]
Nothing -> [FailedReason
NoCommonName]
            Just [Char]
cn -> [FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch [] forall a b. (a -> b) -> a -> b
$ [[Char] -> [FailedReason]
matchDomain [Char]
cn]
  where (Maybe [Char]
commonName, [[Char]]
altNames) = Certificate -> (Maybe [Char], [[Char]])
getNames Certificate
cert

        findMatch :: [FailedReason] -> [[FailedReason]] -> [FailedReason]
        findMatch :: [FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch [FailedReason]
_   []      = [[Char] -> FailedReason
NameMismatch [Char]
fqhn]
        findMatch [FailedReason]
_   ([]:[[FailedReason]]
_)  = []
        findMatch [FailedReason]
acc ([FailedReason]
_ :[[FailedReason]]
xs) = [FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch [FailedReason]
acc [[FailedReason]]
xs

        matchDomain :: String -> [FailedReason]
        matchDomain :: [Char] -> [FailedReason]
matchDomain [Char]
name = case [Char] -> [[Char]]
splitDot [Char]
name of
            [[Char]]
l | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== [Char]
"") [[Char]]
l       -> [[Char] -> FailedReason
InvalidName [Char]
name]
              | forall a. [a] -> a
head [[Char]]
l forall a. Eq a => a -> a -> Bool
== [Char]
"*"       -> [[Char]] -> [FailedReason]
wildcardMatch (forall a. Int -> [a] -> [a]
drop Int
1 [[Char]]
l)
              | [[Char]]
l forall a. Eq a => a -> a -> Bool
== [Char] -> [[Char]]
splitDot [Char]
fqhn  -> [] -- success: we got a match
              | Bool
otherwise           -> [[Char] -> FailedReason
NameMismatch [Char]
fqhn]

        -- A wildcard matches a single domain name component.
        --
        -- e.g. *.server.com will match www.server.com but not www.m.server.com
        --
        -- Only 1 wildcard is valid and only for the left-most component. If
        -- used at other positions or if multiples are present
        -- they won't have a wildcard meaning but will be match as normal star
        -- character to the fqhn and inevitably will fail.
        --
        -- e.g. *.*.server.com will try to litteraly match the '*' subdomain of server.com
        --
        -- Also '*' is not accepted as a valid wildcard
        wildcardMatch :: [[Char]] -> [FailedReason]
wildcardMatch [[Char]]
l
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
l                      = [FailedReason
InvalidWildcard] -- '*' is always invalid
            | [[Char]]
l forall a. Eq a => a -> a -> Bool
== forall a. Int -> [a] -> [a]
drop Int
1 ([Char] -> [[Char]]
splitDot [Char]
fqhn) = [] -- success: we got a match
            | Bool
otherwise                   = [[Char] -> FailedReason
NameMismatch [Char]
fqhn]

        splitDot :: String -> [String]
        splitDot :: [Char] -> [[Char]]
splitDot [] = [[Char]
""]
        splitDot [Char]
x  =
            let ([Char]
y, [Char]
z) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'.') [Char]
x in
            forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
y forall a. a -> [a] -> [a]
: (if [Char]
z forall a. Eq a => a -> a -> Bool
== [Char]
"" then [] else [Char] -> [[Char]]
splitDot forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 [Char]
z)


-- | return true if the 'subject' certificate's issuer match
-- the 'issuer' certificate's subject
matchSI :: DistinguishedName -> Certificate -> Bool
matchSI :: DistinguishedName -> Certificate -> Bool
matchSI DistinguishedName
issuerDN Certificate
issuer = Certificate -> DistinguishedName
certSubjectDN Certificate
issuer forall a. Eq a => a -> a -> Bool
== DistinguishedName
issuerDN

exhaustive :: Bool -> [FailedReason] -> [FailedReason] -> [FailedReason]
exhaustive :: Bool -> [FailedReason] -> [FailedReason] -> [FailedReason]
exhaustive Bool
isExhaustive [FailedReason]
l1 [FailedReason]
l2
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FailedReason]
l1      = [FailedReason]
l2
  | Bool
isExhaustive = [FailedReason]
l1 forall a. [a] -> [a] -> [a]
++ [FailedReason]
l2
  | Bool
otherwise    = [FailedReason]
l1

exhaustiveList :: Bool -> [(Bool, [FailedReason])] -> [FailedReason]
exhaustiveList :: Bool -> [(Bool, [FailedReason])] -> [FailedReason]
exhaustiveList Bool
_            []                    = []
exhaustiveList Bool
isExhaustive ((Bool
performCheck,[FailedReason]
c):[(Bool, [FailedReason])]
cs)
    | Bool
performCheck = Bool -> [FailedReason] -> [FailedReason] -> [FailedReason]
exhaustive Bool
isExhaustive [FailedReason]
c (Bool -> [(Bool, [FailedReason])] -> [FailedReason]
exhaustiveList Bool
isExhaustive [(Bool, [FailedReason])]
cs)
    | Bool
otherwise    = Bool -> [(Bool, [FailedReason])] -> [FailedReason]
exhaustiveList Bool
isExhaustive [(Bool, [FailedReason])]
cs