{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- 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.Monad (when)
import Data.ASN1.Types
import Data.Bits
import Data.ByteString (unpack)
import Data.Char (toLower)
import Data.Default
import Data.Hourglass
import Data.IP (IPv4, IPv6, toIPv4, toIPv6)
import Data.List
import Data.Maybe
import Data.Word (Word8)
import Data.X509
import Data.X509.CertificateStore
import Data.X509.Validation.Cache
import Data.X509.Validation.Fingerprint
import Data.X509.Validation.Signature
import Data.X509.Validation.Types
import Text.Read (readMaybe)
import Time.System

-- | 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
    = -- | certificate contains an unknown critical extension
      UnknownCriticalExtension OID
    | -- | validity ends before checking time
      Expired
    | -- | validity starts after checking time
      InFuture
    | -- | certificate is self signed
      SelfSigned
    | -- | unknown Certificate Authority (CA)
      UnknownCA
    | -- | certificate is not allowed to sign
      NotAllowedToSign
    | -- | not a CA
      NotAnAuthority
    | -- | Violation of the optional Basic constraint's path length
      AuthorityTooDeep
    | -- | Certificate doesn't have any common name (CN)
      NoCommonName
    | -- | Invalid name in certificate
      InvalidName String
    | -- | connection name and certificate do not match
      NameMismatch String
    | -- | invalid wildcard in certificate
      InvalidWildcard
    | -- | the requested key usage is not compatible with the leaf certificate's key usage
      LeafKeyUsageNotAllowed
    | -- | the requested key purpose is not compatible with the leaf certificate's extended key usage
      LeafKeyPurposeNotAllowed
    | -- | Only authorized an X509.V3 certificate as leaf certificate.
      LeafNotV3
    | -- | empty chain of certificate
      EmptyChain
    | -- | the cache explicitely denied this certificate
      CacheSaysNo String
    | -- | signature failed
      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
$cshowsPrec :: Int -> FailedReason -> ShowS
showsPrec :: Int -> FailedReason -> ShowS
$cshow :: FailedReason -> String
show :: FailedReason -> String
$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
    { ValidationChecks -> Bool
checkTimeValidity :: Bool
    -- ^ check time validity of every certificate in the chain.
    -- the make sure that current time is between each validity bounds
    -- in the certificate
    , ValidationChecks -> Maybe DateTime
checkAtTime :: Maybe DateTime
    -- ^ The time when the validity check happens. When set to Nothing,
    -- the current time will be used
    , ValidationChecks -> Bool
checkStrictOrdering :: Bool
    -- ^ 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
checkCAConstraints :: Bool
    -- ^ Check that signing certificate got the CA basic constraint.
    -- this is absolutely not recommended to turn it off.
    , ValidationChecks -> Bool
checkExhaustive :: 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
checkLeafV3 :: 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 -> [ExtKeyUsageFlag]
checkLeafKeyUsage :: [ExtKeyUsageFlag]
    -- ^ 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 -> [ExtKeyUsagePurpose]
checkLeafKeyPurpose :: [ExtKeyUsagePurpose]
    -- ^ 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 -> Bool
checkFQHN :: Bool
    -- ^ 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.
    }
    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
$cshowsPrec :: Int -> ValidationChecks -> ShowS
showsPrec :: Int -> ValidationChecks -> ShowS
$cshow :: ValidationChecks -> String
show :: ValidationChecks -> String
$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
    { ValidationHooks -> DistinguishedName -> Certificate -> Bool
hookMatchSubjectIssuer :: DistinguishedName -> Certificate -> Bool
    -- ^ check whether a given issuer 'DistinguishedName' matches the subject
    -- 'DistinguishedName' of a candidate issuer certificate.
    , ValidationHooks -> DateTime -> Certificate -> [FailedReason]
hookValidateTime :: DateTime -> Certificate -> [FailedReason]
    -- ^ 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 -> String -> Certificate -> [FailedReason]
hookValidateName :: HostName -> Certificate -> [FailedReason]
    -- ^ validate the certificate leaf name with the DNS named used to connect
    , ValidationHooks -> [FailedReason] -> [FailedReason]
hookFilterReason :: [FailedReason] -> [FailedReason]
    -- ^ user filter to modify the list of failure reasons
    }

-- | 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 :: 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

-- | 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 (SignedCertificate
top : [SignedCertificate]
_)) = do
    cacheResult <- (ValidationCache -> ValidationCacheQueryCallback
cacheQuery ValidationCache
cache) ServiceID
ident Fingerprint
fingerPrint (SignedCertificate -> Certificate
getCertificate SignedCertificate
top)
    case cacheResult of
        ValidationCacheResult
ValidationCachePass -> [FailedReason] -> IO [FailedReason]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        ValidationCacheDenied String
s -> [FailedReason] -> IO [FailedReason]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> FailedReason
CacheSaysNo String
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 = SignedCertificate -> HashALG -> Fingerprint
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
getFingerprint SignedCertificate
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 (String
fqhn, ByteString
_) (CertificateChain (SignedCertificate
top : [SignedCertificate]
rchain)) =
    ValidationHooks -> [FailedReason] -> [FailedReason]
hookFilterReason
        ValidationHooks
hooks
        ([FailedReason]
doLeafChecks [FailedReason] -> [FailedReason] -> [FailedReason]
|> Int -> SignedCertificate -> [SignedCertificate] -> [FailedReason]
doCheckChain Int
0 SignedCertificate
top [SignedCertificate]
rchain [FailedReason] -> [FailedReason] -> [FailedReason]
|> SignedCertificate -> [SignedCertificate] -> [FailedReason]
doCheckNameConst SignedCertificate
top [SignedCertificate]
rchain)
  where
    isExhaustive :: Bool
    isExhaustive :: Bool
isExhaustive = ValidationChecks -> Bool
checkExhaustive ValidationChecks
checks

    (|>) :: [FailedReason] -> [FailedReason] -> [FailedReason]
    [FailedReason]
a |> :: [FailedReason] -> [FailedReason] -> [FailedReason]
|> [FailedReason]
b = Bool -> [FailedReason] -> [FailedReason] -> [FailedReason]
exhaustive Bool
isExhaustive [FailedReason]
a [FailedReason]
b

    doLeafChecks :: [FailedReason]
    doLeafChecks :: [FailedReason]
doLeafChecks =
        SignedCertificate -> [FailedReason]
doNameCheck SignedCertificate
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 = SignedCertificate -> Certificate
getCertificate SignedCertificate
top

    doCheckChain
        :: Int -> SignedCertificate -> [SignedCertificate] -> [FailedReason]
    doCheckChain :: Int -> SignedCertificate -> [SignedCertificate] -> [FailedReason]
doCheckChain Int
level SignedCertificate
current [SignedCertificate]
chain =
        Certificate -> [FailedReason]
doCheckCertificate (SignedCertificate -> Certificate
getCertificate SignedCertificate
current)
            -- check if we have a trusted certificate in the store belonging to this issuer.
            [FailedReason] -> [FailedReason] -> [FailedReason]
|> ( case DistinguishedName -> CertificateStore -> Maybe SignedCertificate
findCertificate (Certificate -> DistinguishedName
certIssuerDN Certificate
cert) CertificateStore
store of
                    Just SignedCertificate
trustedSignedCert -> SignedCertificate -> SignedCertificate -> [FailedReason]
checkSignature SignedCertificate
current SignedCertificate
trustedSignedCert
                    Maybe SignedCertificate
Nothing
                        | Certificate -> Bool
isSelfSigned Certificate
cert -> [FailedReason
SelfSigned] [FailedReason] -> [FailedReason] -> [FailedReason]
|> SignedCertificate -> SignedCertificate -> [FailedReason]
checkSignature SignedCertificate
current SignedCertificate
current
                        | [SignedCertificate] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedCertificate]
chain -> [FailedReason
UnknownCA]
                        | Bool
otherwise ->
                            case DistinguishedName
-> [SignedCertificate]
-> Maybe (SignedCertificate, [SignedCertificate])
findIssuer (Certificate -> DistinguishedName
certIssuerDN Certificate
cert) [SignedCertificate]
chain of
                                Maybe (SignedCertificate, [SignedCertificate])
Nothing -> [FailedReason
UnknownCA]
                                Just (SignedCertificate
issuer, [SignedCertificate]
remaining) ->
                                    Int -> Certificate -> [FailedReason]
checkCA Int
level (SignedCertificate -> Certificate
getCertificate SignedCertificate
issuer)
                                        [FailedReason] -> [FailedReason] -> [FailedReason]
|> SignedCertificate -> SignedCertificate -> [FailedReason]
checkSignature SignedCertificate
current SignedCertificate
issuer
                                        [FailedReason] -> [FailedReason] -> [FailedReason]
|> Int -> SignedCertificate -> [SignedCertificate] -> [FailedReason]
doCheckChain (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) SignedCertificate
issuer [SignedCertificate]
remaining
               )
      where
        cert :: Certificate
        cert :: Certificate
cert = SignedCertificate -> Certificate
getCertificate SignedCertificate
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
        -> [SignedCertificate]
        -> Maybe (SignedCertificate, [SignedCertificate])
    findIssuer :: DistinguishedName
-> [SignedCertificate]
-> Maybe (SignedCertificate, [SignedCertificate])
findIssuer DistinguishedName
issuerDN [SignedCertificate]
chain
        | ValidationChecks -> Bool
checkStrictOrdering ValidationChecks
checks =
            case [SignedCertificate]
chain of
                [] -> String -> Maybe (SignedCertificate, [SignedCertificate])
forall a. HasCallStack => String -> a
error String
"not possible"
                (SignedCertificate
c : [SignedCertificate]
cs)
                    | DistinguishedName -> Certificate -> Bool
matchSubjectIdentifier DistinguishedName
issuerDN (SignedCertificate -> Certificate
getCertificate SignedCertificate
c) -> (SignedCertificate, [SignedCertificate])
-> Maybe (SignedCertificate, [SignedCertificate])
forall a. a -> Maybe a
Just (SignedCertificate
c, [SignedCertificate]
cs)
                    | Bool
otherwise -> Maybe (SignedCertificate, [SignedCertificate])
forall a. Maybe a
Nothing
        | Bool
otherwise =
            (\SignedCertificate
x -> (SignedCertificate
x, (SignedCertificate -> Bool)
-> [SignedCertificate] -> [SignedCertificate]
forall a. (a -> Bool) -> [a] -> [a]
filter (SignedCertificate -> SignedCertificate -> Bool
forall a. Eq a => a -> a -> Bool
/= SignedCertificate
x) [SignedCertificate]
chain))
                (SignedCertificate -> (SignedCertificate, [SignedCertificate]))
-> Maybe SignedCertificate
-> Maybe (SignedCertificate, [SignedCertificate])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (SignedCertificate -> Bool)
-> [SignedCertificate] -> Maybe SignedCertificate
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (DistinguishedName -> Certificate -> Bool
matchSubjectIdentifier DistinguishedName
issuerDN (Certificate -> Bool)
-> (SignedCertificate -> Certificate) -> SignedCertificate -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedCertificate -> Certificate
getCertificate) [SignedCertificate]
chain
    matchSubjectIdentifier :: DistinguishedName -> Certificate -> Bool
    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 :: SignedCertificate -> [FailedReason]
    doNameCheck :: SignedCertificate -> [FailedReason]
doNameCheck SignedCertificate
cert
        | Bool -> Bool
not (ValidationChecks -> Bool
checkFQHN ValidationChecks
checks) = []
        | Bool
otherwise = (ValidationHooks -> String -> Certificate -> [FailedReason]
hookValidateName ValidationHooks
hooks) String
fqhn (SignedCertificate -> Certificate
getCertificate SignedCertificate
cert)

    doV3Check :: Certificate -> [FailedReason]
    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 -> [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 -> [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)
            , (Bool
True, Certificate -> [FailedReason]
doCriticalExtensionSweep Certificate
cert)
            ]
    -- check signature of 'signedCert' against the 'signingCert'
    checkSignature
        :: SignedCertificate -> SignedCertificate -> [FailedReason]
    checkSignature :: SignedCertificate -> SignedCertificate -> [FailedReason]
checkSignature SignedCertificate
signedCert SignedCertificate
signingCert =
        case SignedCertificate -> PubKey -> SignatureVerification
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> PubKey -> SignatureVerification
verifySignedSignature SignedCertificate
signedCert (Certificate -> PubKey
certPubKey (Certificate -> PubKey) -> Certificate -> PubKey
forall a b. (a -> b) -> a -> b
$ SignedCertificate -> Certificate
getCertificate SignedCertificate
signingCert) of
            SignatureVerification
SignaturePass -> []
            SignatureFailed SignatureFailure
r -> [SignatureFailure -> FailedReason
InvalidSignature SignatureFailure
r]

    doCheckNameConst :: SignedCertificate -> [SignedCertificate] -> [FailedReason]
    doCheckNameConst :: SignedCertificate -> [SignedCertificate] -> [FailedReason]
doCheckNameConst SignedCertificate
current0 [SignedCertificate]
chain0 = case SignedCertificate
-> [SignedCertificate]
-> [NameConstSpec]
-> Either [FailedReason] [NameConstSpec]
forall {a}.
SignedCertificate
-> [SignedCertificate]
-> [NameConstSpec]
-> Either [a] [NameConstSpec]
loop SignedCertificate
current0 [SignedCertificate]
chain0 [] of
        Left [FailedReason]
errs -> [FailedReason]
errs
        Right [NameConstSpec]
ts -> [NameConstSpec] -> [FailedReason]
checkNameConstraints [NameConstSpec]
ts
      where
        loop :: SignedCertificate
-> [SignedCertificate]
-> [NameConstSpec]
-> Either [a] [NameConstSpec]
loop SignedCertificate
current [SignedCertificate]
chain [NameConstSpec]
acc = case DistinguishedName -> CertificateStore -> Maybe SignedCertificate
findCertificate DistinguishedName
issuer CertificateStore
store of
            Just SignedCertificate
anchor -> [NameConstSpec] -> Either [a] [NameConstSpec]
forall a b. b -> Either a b
Right ([NameConstSpec] -> Either [a] [NameConstSpec])
-> [NameConstSpec] -> Either [a] [NameConstSpec]
forall a b. (a -> b) -> a -> b
$ Certificate -> Bool -> NameConstSpec
getNameConstSpec (SignedCertificate -> Certificate
getCertificate SignedCertificate
anchor) Bool
True NameConstSpec -> [NameConstSpec] -> [NameConstSpec]
forall a. a -> [a] -> [a]
: NameConstSpec
spec NameConstSpec -> [NameConstSpec] -> [NameConstSpec]
forall a. a -> [a] -> [a]
: [NameConstSpec]
acc
            Maybe SignedCertificate
Nothing
                | [SignedCertificate] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedCertificate]
chain -> [a] -> Either [a] [NameConstSpec]
forall a b. a -> Either a b
Left [] -- to pass the test
                | Bool
otherwise -> case DistinguishedName
-> [SignedCertificate]
-> Maybe (SignedCertificate, [SignedCertificate])
findIssuer DistinguishedName
issuer [SignedCertificate]
chain of
                    Maybe (SignedCertificate, [SignedCertificate])
Nothing -> [a] -> Either [a] [NameConstSpec]
forall a b. a -> Either a b
Left [] -- to pass the test
                    Just (SignedCertificate
issuer', [SignedCertificate]
remaining) -> SignedCertificate
-> [SignedCertificate]
-> [NameConstSpec]
-> Either [a] [NameConstSpec]
loop SignedCertificate
issuer' [SignedCertificate]
remaining (NameConstSpec
spec NameConstSpec -> [NameConstSpec] -> [NameConstSpec]
forall a. a -> [a] -> [a]
: [NameConstSpec]
acc)
          where
            cert :: Certificate
cert = SignedCertificate -> Certificate
getCertificate SignedCertificate
current
            issuer :: DistinguishedName
issuer = Certificate -> DistinguishedName
certIssuerDN Certificate
cert
            spec :: NameConstSpec
spec = Certificate -> Bool -> NameConstSpec
getNameConstSpec Certificate
cert (SignedCertificate
current0 SignedCertificate -> SignedCertificate -> Bool
forall a. Eq a => a -> a -> Bool
/= SignedCertificate
current)

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

data NameConstSpec = NameConstSpec
    { NameConstSpec -> [AltName]
ncSANs :: [AltName]
    , NameConstSpec -> Maybe ExtNameConstraints
ncExt :: Maybe ExtNameConstraints
    , NameConstSpec -> Bool
ncSelfSigned :: Bool
    , NameConstSpec -> Bool
ncCA :: Bool
    }

getNameConstSpec :: Certificate -> Bool -> NameConstSpec
getNameConstSpec :: Certificate -> Bool -> NameConstSpec
getNameConstSpec Certificate
cert Bool
ca =
    NameConstSpec
        { ncSANs :: [AltName]
ncSANs = [AltName]
sans
        , ncExt :: Maybe ExtNameConstraints
ncExt = Extensions -> Maybe ExtNameConstraints
forall a. Extension a => Extensions -> Maybe a
extensionGet Extensions
exts
        , ncSelfSigned :: Bool
ncSelfSigned = Certificate -> Bool
isSelfSigned Certificate
cert
        , ncCA :: Bool
ncCA = Bool
ca
        }
  where
    exts :: Extensions
exts = Certificate -> Extensions
certExtensions Certificate
cert
    subj :: AltName
subj = DistinguishedName -> AltName
AltNameDN (DistinguishedName -> AltName) -> DistinguishedName -> AltName
forall a b. (a -> b) -> a -> b
$ Certificate -> DistinguishedName
certSubjectDN Certificate
cert
    sans :: [AltName]
    sans :: [AltName]
sans = case Extensions -> Maybe ExtSubjectAltName
forall a. Extension a => Extensions -> Maybe a
extensionGet Extensions
exts of
        Maybe ExtSubjectAltName
Nothing -> [AltName
subj]
        Just (ExtSubjectAltName [AltName]
alts) -> AltName
subj AltName -> [AltName] -> [AltName]
forall a. a -> [a] -> [a]
: [AltName]
alts

-- | 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 String, [String])
getNames Certificate
cert = (Maybe ASN1CharacterString
commonName Maybe ASN1CharacterString
-> (ASN1CharacterString -> Maybe String) -> Maybe String
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 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

data IPAddress
    = IPv4Address IPv4
    | IPv6Address IPv6
    deriving (IPAddress -> IPAddress -> Bool
(IPAddress -> IPAddress -> Bool)
-> (IPAddress -> IPAddress -> Bool) -> Eq IPAddress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IPAddress -> IPAddress -> Bool
== :: IPAddress -> IPAddress -> Bool
$c/= :: IPAddress -> IPAddress -> Bool
/= :: IPAddress -> IPAddress -> Bool
Eq)

getIPs :: Certificate -> [IPAddress]
getIPs :: Certificate -> [IPAddress]
getIPs Certificate
cert = [IPAddress] -> Maybe [IPAddress] -> [IPAddress]
forall a. a -> Maybe a -> a
fromMaybe [] (ExtSubjectAltName -> [IPAddress]
toAltName (ExtSubjectAltName -> [IPAddress])
-> Maybe ExtSubjectAltName -> Maybe [IPAddress]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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))
  where
    toAltName :: ExtSubjectAltName -> [IPAddress]
toAltName (ExtSubjectAltName [AltName]
names) = [Maybe IPAddress] -> [IPAddress]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe IPAddress] -> [IPAddress])
-> [Maybe IPAddress] -> [IPAddress]
forall a b. (a -> b) -> a -> b
$ (AltName -> Maybe IPAddress) -> [AltName] -> [Maybe IPAddress]
forall a b. (a -> b) -> [a] -> [b]
map AltName -> Maybe IPAddress
unAltName [AltName]
names

    unAltName :: AltName -> Maybe IPAddress
unAltName (AltNameIP ByteString
s) = case ByteString -> [Word8]
unpack ByteString
s of
        [Word8
a, Word8
b, Word8
c, Word8
d] -> IPAddress -> Maybe IPAddress
forall a. a -> Maybe a
Just (IPAddress -> Maybe IPAddress) -> IPAddress -> Maybe IPAddress
forall a b. (a -> b) -> a -> b
$ IPv4 -> IPAddress
IPv4Address (IPv4 -> IPAddress) -> IPv4 -> IPAddress
forall a b. (a -> b) -> a -> b
$ [Int] -> IPv4
toIPv4 ([Int] -> IPv4) -> [Int] -> IPv4
forall a b. (a -> b) -> a -> b
$ (Word8 -> Int) -> [Word8] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word8
a, Word8
b, Word8
c, Word8
d]
        [Word8
a, Word8
b, Word8
c, Word8
d, Word8
e, Word8
f, Word8
g, Word8
h, Word8
i, Word8
j, Word8
k, Word8
l, Word8
m, Word8
n, Word8
o, Word8
p] ->
            IPAddress -> Maybe IPAddress
forall a. a -> Maybe a
Just (IPAddress -> Maybe IPAddress) -> IPAddress -> Maybe IPAddress
forall a b. (a -> b) -> a -> b
$
                IPv6 -> IPAddress
IPv6Address (IPv6 -> IPAddress) -> IPv6 -> IPAddress
forall a b. (a -> b) -> a -> b
$
                    [Int] -> IPv6
toIPv6
                        [ Word8 -> Word8 -> Int
fuse Word8
a Word8
b
                        , Word8 -> Word8 -> Int
fuse Word8
c Word8
d
                        , Word8 -> Word8 -> Int
fuse Word8
e Word8
f
                        , Word8 -> Word8 -> Int
fuse Word8
g Word8
h
                        , Word8 -> Word8 -> Int
fuse Word8
i Word8
j
                        , Word8 -> Word8 -> Int
fuse Word8
k Word8
l
                        , Word8 -> Word8 -> Int
fuse Word8
m Word8
n
                        , Word8 -> Word8 -> Int
fuse Word8
o Word8
p
                        ]
        [Word8]
_ -> Maybe IPAddress
forall a. Maybe a
Nothing
    unAltName AltName
_ = Maybe IPAddress
forall a. Maybe a
Nothing

    fuse :: Word8 -> Word8 -> Int
    fuse :: Word8 -> Word8 -> Int
fuse Word8
a Word8
b = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a) Int
8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b)

parseIPAddress :: HostName -> Maybe IPAddress
parseIPAddress :: String -> Maybe IPAddress
parseIPAddress (String -> Maybe IPv4
forall a. Read a => String -> Maybe a
readMaybe -> Just IPv4
ipV4) = IPAddress -> Maybe IPAddress
forall a. a -> Maybe a
Just (IPAddress -> Maybe IPAddress) -> IPAddress -> Maybe IPAddress
forall a b. (a -> b) -> a -> b
$ IPv4 -> IPAddress
IPv4Address IPv4
ipV4
parseIPAddress (String -> Maybe IPv6
forall a. Read a => String -> Maybe a
readMaybe -> Just IPv6
ipV6) = IPAddress -> Maybe IPAddress
forall a. a -> Maybe a
Just (IPAddress -> Maybe IPAddress) -> IPAddress -> Maybe IPAddress
forall a b. (a -> b) -> a -> b
$ IPv6 -> IPAddress
IPv6Address IPv6
ipV6
parseIPAddress String
_ = Maybe IPAddress
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 and IP Addresses, 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 :: 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
altNames =
        case String -> Maybe IPAddress
parseIPAddress String
fqhn of
            Maybe IPAddress
Nothing -> [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
            Just IPAddress
ip ->
                if IPAddress -> [IPAddress] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem IPAddress
ip (Certificate -> [IPAddress]
getIPs Certificate
cert)
                    then []
                    else [String -> FailedReason
NameMismatch String
fqhn]
    | 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. HasCallStack => [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 -> [] -- success: we got a match
            | Bool
otherwise -> [String -> FailedReason
NameMismatch String
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 :: [String] -> [FailedReason]
wildcardMatch [String]
l
        | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
l = [FailedReason
InvalidWildcard] -- '*' is always invalid
        | [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) = [] -- success: we got a match
        | 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)

-- | 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

checkNameConstraints :: [NameConstSpec] -> [FailedReason]
checkNameConstraints :: [NameConstSpec] -> [FailedReason]
checkNameConstraints [NameConstSpec]
xs0 = [NameConstSpec] -> [FailedReason]
loop [NameConstSpec]
xs0
  where
    loop :: [NameConstSpec] -> [FailedReason]
loop [] = []
    loop [NameConstSpec
_] = []
    loop [NameConstSpec
a, NameConstSpec
b] = NameConstSpec -> NameConstSpec -> [FailedReason]
check NameConstSpec
a NameConstSpec
b
    loop (NameConstSpec
a : NameConstSpec
b : [NameConstSpec]
cs) =
        NameConstSpec -> NameConstSpec -> [FailedReason]
check NameConstSpec
a NameConstSpec
b [FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ case NameConstSpec
-> NameConstSpec -> Either [FailedReason] NameConstSpec
nextNameConstSpec NameConstSpec
a NameConstSpec
b of
            Left [FailedReason]
errs -> [FailedReason]
errs
            Right NameConstSpec
b' -> [NameConstSpec] -> [FailedReason]
loop (NameConstSpec
b' NameConstSpec -> [NameConstSpec] -> [NameConstSpec]
forall a. a -> [a] -> [a]
: [NameConstSpec]
cs)

    check :: NameConstSpec -> NameConstSpec -> [FailedReason]
check NameConstSpec
ncs0 NameConstSpec
ncs1
        | NameConstSpec -> Bool
ncSelfSigned NameConstSpec
ncs1 = []
        | Bool
otherwise = case NameConstSpec -> Maybe ExtNameConstraints
ncExt NameConstSpec
ncs0 of
            Maybe ExtNameConstraints
Nothing -> []
            Just ExtNameConstraints
nc0 -> [AltName] -> ExtNameConstraints -> [FailedReason]
validateNamesInSubtrees (NameConstSpec -> [AltName]
ncSANs NameConstSpec
ncs1) ExtNameConstraints
nc0

nextNameConstSpec
    :: NameConstSpec
    -> NameConstSpec
    -> Either [FailedReason] NameConstSpec
nextNameConstSpec :: NameConstSpec
-> NameConstSpec -> Either [FailedReason] NameConstSpec
nextNameConstSpec NameConstSpec
ncs0 NameConstSpec
ncs1
    | Bool -> Bool
not (NameConstSpec -> Bool
ncCA NameConstSpec
ncs1) = NameConstSpec -> Either [FailedReason] NameConstSpec
forall a b. b -> Either a b
Right NameConstSpec
ncs1
    | Bool
otherwise = case Maybe ExtNameConstraints
-> Maybe ExtNameConstraints
-> Either [FailedReason] (Maybe ExtNameConstraints)
stricter (NameConstSpec -> Maybe ExtNameConstraints
ncExt NameConstSpec
ncs0) (NameConstSpec -> Maybe ExtNameConstraints
ncExt NameConstSpec
ncs1) of
        Left [FailedReason]
errs -> [FailedReason] -> Either [FailedReason] NameConstSpec
forall a b. a -> Either a b
Left [FailedReason]
errs
        Right Maybe ExtNameConstraints
mNC -> NameConstSpec -> Either [FailedReason] NameConstSpec
forall a b. b -> Either a b
Right (NameConstSpec -> Either [FailedReason] NameConstSpec)
-> NameConstSpec -> Either [FailedReason] NameConstSpec
forall a b. (a -> b) -> a -> b
$ NameConstSpec
ncs1{ncExt = mNC}

stricter
    :: Maybe ExtNameConstraints -- issuer: should be looser
    -> Maybe ExtNameConstraints -- should be stricter
    -> Either [FailedReason] (Maybe ExtNameConstraints)
stricter :: Maybe ExtNameConstraints
-> Maybe ExtNameConstraints
-> Either [FailedReason] (Maybe ExtNameConstraints)
stricter Maybe ExtNameConstraints
Nothing Maybe ExtNameConstraints
mnc = Maybe ExtNameConstraints
-> Either [FailedReason] (Maybe ExtNameConstraints)
forall a b. b -> Either a b
Right Maybe ExtNameConstraints
mnc
stricter (Just ExtNameConstraints
x) Maybe ExtNameConstraints
Nothing = [FailedReason] -> Either [FailedReason] (Maybe ExtNameConstraints)
forall a b. a -> Either a b
Left [String -> FailedReason
InvalidName (String -> FailedReason) -> String -> FailedReason
forall a b. (a -> b) -> a -> b
$ ExtNameConstraints -> String
forall a. Show a => a -> String
show ExtNameConstraints
x]
stricter
    (Just (ExtNameConstraints [GeneralSubtree]
permitted0 [GeneralSubtree]
excluded0))
    (Just (ExtNameConstraints [GeneralSubtree]
permitted1 [GeneralSubtree]
excluded1))
        | [FailedReason] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FailedReason]
errs =
            Maybe ExtNameConstraints
-> Either [FailedReason] (Maybe ExtNameConstraints)
forall a b. b -> Either a b
Right (Maybe ExtNameConstraints
 -> Either [FailedReason] (Maybe ExtNameConstraints))
-> Maybe ExtNameConstraints
-> Either [FailedReason] (Maybe ExtNameConstraints)
forall a b. (a -> b) -> a -> b
$ ExtNameConstraints -> Maybe ExtNameConstraints
forall a. a -> Maybe a
Just (ExtNameConstraints -> Maybe ExtNameConstraints)
-> ExtNameConstraints -> Maybe ExtNameConstraints
forall a b. (a -> b) -> a -> b
$ [GeneralSubtree] -> [GeneralSubtree] -> ExtNameConstraints
ExtNameConstraints [GeneralSubtree]
permitted1 ([GeneralSubtree]
excluded1 [GeneralSubtree] -> [GeneralSubtree] -> [GeneralSubtree]
forall a. [a] -> [a] -> [a]
++ [GeneralSubtree]
excluded0)
        | Bool
otherwise = [FailedReason] -> Either [FailedReason] (Maybe ExtNameConstraints)
forall a b. a -> Either a b
Left [FailedReason]
errs
      where
        errs :: [FailedReason]
errs = [GeneralSubtree] -> [GeneralSubtree] -> [FailedReason]
strictCheck [GeneralSubtree]
permitted0 [GeneralSubtree]
permitted1

strictCheck :: [GeneralSubtree] -> [GeneralSubtree] -> [FailedReason]
strictCheck :: [GeneralSubtree] -> [GeneralSubtree] -> [FailedReason]
strictCheck [GeneralSubtree]
permitted0 [GeneralSubtree]
permitted1 = (GeneralSubtree -> [FailedReason])
-> [GeneralSubtree] -> [FailedReason]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GeneralSubtree -> [FailedReason]
f [GeneralSubtree]
permitted1
  where
    f :: GeneralSubtree -> [FailedReason]
f (GeneralSubtree AltName
a Integer
_ Maybe Integer
_)
        | (GeneralSubtree -> Bool) -> [GeneralSubtree] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\GeneralSubtree
g -> (AltName
a AltName -> GeneralSubtree -> Maybe Bool
`isIncludedIn` GeneralSubtree
g) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) [GeneralSubtree]
permitted0 = []
        | Bool
otherwise = [String -> FailedReason
InvalidName (String -> FailedReason) -> String -> FailedReason
forall a b. (a -> b) -> a -> b
$ AltName -> String
forall a. Show a => a -> String
show AltName
a]

validateNamesInSubtrees :: [AltName] -> ExtNameConstraints -> [FailedReason]
validateNamesInSubtrees :: [AltName] -> ExtNameConstraints -> [FailedReason]
validateNamesInSubtrees [AltName]
altNames (ExtNameConstraints [GeneralSubtree]
permitted [GeneralSubtree]
excluded) =
    (AltName -> [FailedReason]) -> [AltName] -> [FailedReason]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AltName -> [FailedReason]
inc [AltName]
altNames [FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ (AltName -> [FailedReason]) -> [AltName] -> [FailedReason]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AltName -> [FailedReason]
exc [AltName]
altNames
  where
    inc :: AltName -> [FailedReason]
inc AltName
a
        | AltName -> [GeneralSubtree] -> Bool
nsMatch AltName
a [GeneralSubtree]
permitted = []
        | Bool
otherwise = [String -> FailedReason
InvalidName (String -> FailedReason) -> String -> FailedReason
forall a b. (a -> b) -> a -> b
$ AltName -> String
forall a. Show a => a -> String
show AltName
a]
    exc :: AltName -> [FailedReason]
exc AltName
a
        | AltName -> [GeneralSubtree] -> Bool
nsNotMatch AltName
a [GeneralSubtree]
excluded = []
        | Bool
otherwise = [String -> FailedReason
InvalidName (String -> FailedReason) -> String -> FailedReason
forall a b. (a -> b) -> a -> b
$ AltName -> String
forall a. Show a => a -> String
show AltName
a]

nsMatch :: AltName -> [GeneralSubtree] -> Bool
nsMatch :: AltName -> [GeneralSubtree] -> Bool
nsMatch AltName
a [GeneralSubtree]
gs = (Maybe Bool -> Bool) -> [Maybe Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) [Maybe Bool]
rs Bool -> Bool -> Bool
|| (Maybe Bool -> Bool) -> [Maybe Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe Bool]
rs
  where
    rs :: [Maybe Bool]
rs = (GeneralSubtree -> Maybe Bool) -> [GeneralSubtree] -> [Maybe Bool]
forall a b. (a -> b) -> [a] -> [b]
map (AltName
a AltName -> GeneralSubtree -> Maybe Bool
`isIncludedIn`) [GeneralSubtree]
gs

nsNotMatch :: AltName -> [GeneralSubtree] -> Bool
nsNotMatch :: AltName -> [GeneralSubtree] -> Bool
nsNotMatch AltName
a [GeneralSubtree]
gs = (GeneralSubtree -> Bool) -> [GeneralSubtree] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\GeneralSubtree
g -> (AltName
a AltName -> GeneralSubtree -> Maybe Bool
`isIncludedIn` GeneralSubtree
g) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) [GeneralSubtree]
gs

isIncludedIn :: AltName -> GeneralSubtree -> Maybe Bool
isIncludedIn :: AltName -> GeneralSubtree -> Maybe Bool
isIncludedIn (AltNameDN DistinguishedName
nm0) (GeneralSubtree (AltNameDN DistinguishedName
nm1) Integer
_ Maybe Integer
_) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (DistinguishedName
nm0 DistinguishedName -> DistinguishedName -> Bool
forall a. Eq a => a -> a -> Bool
== DistinguishedName
nm1)
isIncludedIn (AltNameDNS String
nm0) (GeneralSubtree (AltNameDNS String
nm1) Integer
_ Maybe Integer
_) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (String
nm0 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
nm1 Bool -> Bool -> Bool
|| (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: String
nm1) String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
nm0)
-- isIncludedIn (AltNameRFC822 _) (GeneralSubtree  (AltNameRFC822 _) _ _)= undefined
-- isIncludedIn (AltNameURI _) (GeneralSubtree  (AltNameURI _) _ _)= undefined
-- isIncludedIn (AltNameIP _) (GeneralSubtree (AltNameIP _) _ _)= undefined
isIncludedIn AltName
_ GeneralSubtree
_ = Maybe Bool
forall a. Maybe a
Nothing

doCriticalExtensionSweep :: Certificate -> [FailedReason]
doCriticalExtensionSweep :: Certificate -> [FailedReason]
doCriticalExtensionSweep Certificate
cert = case Maybe [ExtensionRaw]
mexts of
    Maybe [ExtensionRaw]
Nothing -> []
    Just [ExtensionRaw]
exts ->
        [ OID -> FailedReason
UnknownCriticalExtension OID
oid
        | ExtensionRaw OID
oid Bool
critical ByteString
_ <- [ExtensionRaw]
exts
        , Bool
critical
        , OID
oid OID -> [OID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [OID]
recognizedOIDs
        ]
  where
    Extensions Maybe [ExtensionRaw]
mexts = Certificate -> Extensions
certExtensions Certificate
cert