    -- |
    -- 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]
    (Int -> FailedReason -> ShowS)
    -> (FailedReason -> [Char])
    -> ([FailedReason] -> ShowS)
    -> Show FailedReason
    forall a.
    (Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> FailedReason -> ShowS
    showsPrec :: Int -> FailedReason -> ShowS
    $cshow :: FailedReason -> [Char]
    show :: FailedReason -> [Char]
    $cshowList :: [FailedReason] -> ShowS
    showList :: [FailedReason] -> ShowS
    Show,FailedReason -> FailedReason -> Bool
    (FailedReason -> FailedReason -> Bool)
    -> (FailedReason -> FailedReason -> Bool) -> Eq FailedReason
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: FailedReason -> FailedReason -> Bool
    == :: FailedReason -> FailedReason -> Bool
    $c/= :: FailedReason -> FailedReason -> Bool
    /= :: 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]
    (Int -> ValidationChecks -> ShowS)
    -> (ValidationChecks -> [Char])
    -> ([ValidationChecks] -> ShowS)
    -> Show ValidationChecks
    forall a.
    (Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> ValidationChecks -> ShowS
    showsPrec :: Int -> ValidationChecks -> ShowS
    $cshow :: ValidationChecks -> [Char]
    show :: ValidationChecks -> [Char]
    $cshowList :: [ValidationChecks] -> ShowS
    showList :: [ValidationChecks] -> ShowS
    Show,ValidationChecks -> ValidationChecks -> Bool
    (ValidationChecks -> ValidationChecks -> Bool)
    -> (ValidationChecks -> ValidationChecks -> Bool)
    -> Eq ValidationChecks
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: ValidationChecks -> ValidationChecks -> Bool
    == :: ValidationChecks -> ValidationChecks -> Bool
    $c/= :: ValidationChecks -> ValidationChecks -> Bool
    /= :: 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         = 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

    -- | 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       = [FailedReason] -> [FailedReason]
    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 []) = [FailedReason] -> IO [FailedReason]
    forall a. a -> IO a
    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
        cacheResult <- (ValidationCache -> ValidationCacheQueryCallback
    cacheQuery ValidationCache
    cache) ServiceID
    ident Fingerprint
    fingerPrint (SignedExact Certificate -> Certificate
    getCertificate SignedExact Certificate
    top)
        case cacheResult of
            ValidationCacheResult
    ValidationCachePass     -> [FailedReason] -> IO [FailedReason]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
            ValidationCacheDenied [Char]
    s -> [FailedReason] -> IO [FailedReason]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [[Char] -> FailedReason
    CacheSaysNo [Char]
    s]
            ValidationCacheResult
    ValidationCacheUnknown  -> do
                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 a. a -> IO a
    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
                let failedReasons = DateTime
    -> ValidationHooks
    -> ValidationChecks
    -> CertificateStore
    -> ServiceID
    -> CertificateChain
    -> [FailedReason]
    validatePure DateTime
    validationTime ValidationHooks
    hooks ValidationChecks
    checks CertificateStore
    store ServiceID
    ident CertificateChain
    cc
                when (null failedReasons) $ (cacheAdd cache) ident fingerPrint (getCertificate top)
                return 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

    -- | 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 [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] -> [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      -> 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
    SelfSigned] [FailedReason] -> [FailedReason] -> [FailedReason]
    |> 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 a. [a] -> Bool
    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]
    |> 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
                                        [FailedReason] -> [FailedReason] -> [FailedReason]
    |> Int
    -> SignedExact Certificate
    -> [SignedExact Certificate]
    -> [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
            -- 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
                        []     -> [Char]
    -> Maybe (SignedExact Certificate, [SignedExact Certificate])
    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) -> (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 a b. (a -> b) -> Maybe a -> Maybe b
    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

            -- 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)          = []
                | [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 a. Eq a => a -> [a] -> 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 -> [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 =
                   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
                    -- 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
                        | [a] -> Bool
    forall a. [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 -> [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 DistinguishedName -> DistinguishedName -> Bool
    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 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]

    -- | Validate that the current time is between validity bounds
    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 [Char], [[Char]])
    getNames Certificate
    cert = (Maybe ASN1CharacterString
    commonName Maybe ASN1CharacterString
    -> (ASN1CharacterString -> Maybe [Char]) -> Maybe [Char]
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    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 (DistinguishedName -> Maybe ASN1CharacterString)
    -> DistinguishedName -> Maybe ASN1CharacterString
    forall a b. (a -> b) -> a -> b
    $ Certificate -> DistinguishedName
    certSubjectDN Certificate
    cert
            altNames :: [[Char]]
    altNames   = [[Char]]
    -> (ExtSubjectAltName -> [[Char]])
    -> Maybe ExtSubjectAltName
    -> [[Char]]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [] ExtSubjectAltName -> [[Char]]
    toAltName (Maybe ExtSubjectAltName -> [[Char]])
    -> Maybe ExtSubjectAltName -> [[Char]]
    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 -> [[Char]]
    toAltName (ExtSubjectAltName [AltName]
    names) = [Maybe [Char]] -> [[Char]]
    forall a. [Maybe a] -> [a]
    catMaybes ([Maybe [Char]] -> [[Char]]) -> [Maybe [Char]] -> [[Char]]
    forall a b. (a -> b) -> a -> b
    $ (AltName -> Maybe [Char]) -> [AltName] -> [Maybe [Char]]
    forall a b. (a -> b) -> [a] -> [b]
    map AltName -> Maybe [Char]
    unAltName [AltName]
    names
                where unAltName :: AltName -> Maybe [Char]
    unAltName (AltNameDNS [Char]
    s) = [Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just [Char]
    s
                      unAltName AltName
    _              = Maybe [Char]
    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 (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ [[Char]] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [[Char]]
    altNames =
            [FailedReason] -> [[FailedReason]] -> [FailedReason]
    findMatch [] ([[FailedReason]] -> [FailedReason])
    -> [[FailedReason]] -> [FailedReason]
    forall a b. (a -> b) -> a -> b
    $ ([Char] -> [FailedReason]) -> [[Char]] -> [[FailedReason]]
    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 [] ([[FailedReason]] -> [FailedReason])
    -> [[FailedReason]] -> [FailedReason]
    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 | ([Char] -> Bool) -> [[Char]] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any ([Char] -> [Char] -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Char]
    "") [[Char]]
    l       -> [[Char] -> FailedReason
    InvalidName [Char]
    name]
                  | [[Char]] -> [Char]
    forall a. HasCallStack => [a] -> a
    head [[Char]]
    l [Char] -> [Char] -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Char]
    "*"       -> [[Char]] -> [FailedReason]
    wildcardMatch (Int -> [[Char]] -> [[Char]]
    forall a. Int -> [a] -> [a]
    drop Int
    1 [[Char]]
    l)
                  | [[Char]]
    l [[Char]] -> [[Char]] -> Bool
    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
                | [[Char]] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [[Char]]
    l                      = [FailedReason
    InvalidWildcard] -- '*' is always invalid
                | [[Char]]
    l [[Char]] -> [[Char]] -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int -> [[Char]] -> [[Char]]
    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) = (Char -> Bool) -> [Char] -> ([Char], [Char])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.') [Char]
    x in
                (Char -> Char) -> ShowS
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toLower [Char]
    y [Char] -> [[Char]] -> [[Char]]
    forall a. a -> [a] -> [a]
    : (if [Char]
    z [Char] -> [Char] -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Char]
    "" then [] else [Char] -> [[Char]]
    splitDot ([Char] -> [[Char]]) -> [Char] -> [[Char]]
    forall a b. (a -> b) -> a -> b
    $ Int -> ShowS
    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 DistinguishedName -> DistinguishedName -> Bool
    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
      | [FailedReason] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [FailedReason]
    l1      = [FailedReason]
    l2
      | Bool
    isExhaustive = [FailedReason]
    l1 [FailedReason] -> [FailedReason] -> [FailedReason]
    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