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

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

-- | 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 -> String -> 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 :: Bool
-> Maybe DateTime
-> Bool
-> Bool
-> Bool
-> Bool
-> [ExtKeyUsageFlag]
-> [ExtKeyUsagePurpose]
-> Bool
-> ValidationChecks
ValidationChecks
    { checkTimeValidity :: Bool
checkTimeValidity   = Bool
True
    , checkAtTime :: Maybe DateTime
checkAtTime         = Maybe DateTime
forall a. Maybe a
Nothing
    , checkStrictOrdering :: Bool
checkStrictOrdering = Bool
False
    , checkCAConstraints :: Bool
checkCAConstraints  = Bool
True
    , checkExhaustive :: Bool
checkExhaustive     = Bool
False
    , checkLeafV3 :: Bool
checkLeafV3         = Bool
True
    , checkLeafKeyUsage :: [ExtKeyUsageFlag]
checkLeafKeyUsage   = []
    , checkLeafKeyPurpose :: [ExtKeyUsagePurpose]
checkLeafKeyPurpose = []
    , checkFQHN :: Bool
checkFQHN           = Bool
True
    }

instance Default ValidationChecks where
    def :: ValidationChecks
def = ValidationChecks
defaultChecks

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

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

-- | 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 (m :: * -> *) a. Monad m => a -> m a
return [FailedReason
EmptyChain]
validate HashALG
hashAlg ValidationHooks
hooks ValidationChecks
checks CertificateStore
store ValidationCache
cache ServiceID
ident cc :: CertificateChain
cc@(CertificateChain (SignedExact Certificate
top:[SignedExact Certificate]
_)) = do
    ValidationCacheResult
cacheResult <- (ValidationCache -> ValidationCacheQueryCallback
cacheQuery ValidationCache
cache) ServiceID
ident Fingerprint
fingerPrint (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
top)
    case ValidationCacheResult
cacheResult of
        ValidationCacheResult
ValidationCachePass     -> [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        ValidationCacheDenied String
s -> [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> FailedReason
CacheSaysNo String
s]
        ValidationCacheResult
ValidationCacheUnknown  -> do
            DateTime
validationTime <- IO DateTime
-> (DateTime -> IO DateTime) -> Maybe DateTime -> IO DateTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Elapsed -> DateTime
forall t1 t2. (Timeable t1, Time t2) => t1 -> t2
timeConvert (Elapsed -> DateTime) -> IO Elapsed -> IO DateTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Elapsed
timeCurrent) DateTime -> IO DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DateTime -> IO DateTime) -> Maybe DateTime -> IO DateTime
forall a b. (a -> b) -> a -> b
$ ValidationChecks -> Maybe DateTime
checkAtTime ValidationChecks
checks
            [FailedReason]
failedReasons <- DateTime
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
doValidate DateTime
validationTime ValidationHooks
hooks ValidationChecks
checks CertificateStore
store ServiceID
ident CertificateChain
cc
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FailedReason] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FailedReason]
failedReasons) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (ValidationCache -> ValidationCacheAddCallback
cacheAdd ValidationCache
cache) ServiceID
ident Fingerprint
fingerPrint (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
top)
            [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason]
failedReasons
  where fingerPrint :: Fingerprint
fingerPrint = SignedExact Certificate -> HashALG -> Fingerprint
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
getFingerprint SignedExact Certificate
top HashALG
hashAlg


-- | Validate a certificate chain with explicit parameters
doValidate :: DateTime
           -> ValidationHooks
           -> ValidationChecks
           -> CertificateStore
           -> ServiceID
           -> CertificateChain
           -> IO [FailedReason]
doValidate :: DateTime
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
doValidate DateTime
_              ValidationHooks
_     ValidationChecks
_      CertificateStore
_     ServiceID
_        (CertificateChain [])           = [FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason
EmptyChain]
doValidate DateTime
validationTime ValidationHooks
hooks ValidationChecks
checks CertificateStore
store (String
fqhn,ByteString
_) (CertificateChain (SignedExact Certificate
top:[SignedExact Certificate]
rchain)) =
   (ValidationHooks -> [FailedReason] -> [FailedReason]
hookFilterReason ValidationHooks
hooks) ([FailedReason] -> [FailedReason])
-> IO [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([FailedReason] -> IO [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason]
doLeafChecks IO [FailedReason] -> IO [FailedReason] -> IO [FailedReason]
forall (m :: * -> *).
Monad m =>
m [FailedReason] -> m [FailedReason] -> m [FailedReason]
|> Int
-> SignedExact Certificate
-> [SignedExact Certificate]
-> IO [FailedReason]
doCheckChain Int
0 SignedExact Certificate
top [SignedExact Certificate]
rchain)
  where isExhaustive :: Bool
isExhaustive = ValidationChecks -> Bool
checkExhaustive ValidationChecks
checks
        m [FailedReason]
a |> :: m [FailedReason] -> m [FailedReason] -> m [FailedReason]
|> m [FailedReason]
b = Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
forall (m :: * -> *).
Monad m =>
Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
exhaustive Bool
isExhaustive m [FailedReason]
a m [FailedReason]
b

        doLeafChecks :: [FailedReason]
doLeafChecks = SignedExact Certificate -> [FailedReason]
doNameCheck SignedExact Certificate
top [FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ Certificate -> [FailedReason]
doV3Check Certificate
topCert [FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ Certificate -> [FailedReason]
doKeyUsageCheck Certificate
topCert
            where topCert :: Certificate
topCert = SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
top

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

        -- 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtKeyUsageFlag]
flags
                                Maybe ExtKeyUsage
Nothing                  -> Bool
True
                (Bool
allowedCA,Maybe Integer
pathLen) = case Extensions -> Maybe ExtBasicConstraints
forall a. Extension a => Extensions -> Maybe a
extensionGet Extensions
extensions of
                                Just (ExtBasicConstraints Bool
True Maybe Integer
pl) -> (Bool
True, Maybe Integer
pl)
                                Maybe ExtBasicConstraints
_                                  -> (Bool
False, Maybe Integer
forall a. Maybe a
Nothing)
                allowedDepth :: Bool
allowedDepth = case Maybe Integer
pathLen of
                                    Maybe Integer
Nothing                            -> Bool
True
                                    Just Integer
pl | Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
level -> Bool
True
                                            | Bool
otherwise                -> Bool
False

        doNameCheck :: SignedExact Certificate -> [FailedReason]
doNameCheck SignedExact Certificate
cert
            | Bool -> Bool
not (ValidationChecks -> Bool
checkFQHN ValidationChecks
checks) = []
            | Bool
otherwise              = (ValidationHooks -> String -> Certificate -> [FailedReason]
hookValidateName ValidationHooks
hooks) String
fqhn (SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
cert)

        doV3Check :: Certificate -> [FailedReason]
doV3Check Certificate
cert
            | ValidationChecks -> Bool
checkLeafV3 ValidationChecks
checks = case Certificate -> Int
certVersion Certificate
cert of
                                        Int
2 {- 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 (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
expected                       = []
                    | [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
intersect [a]
expected [a]
list [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
expected = []
                    | Bool
otherwise                           = [a
err]

        doCheckCertificate :: Certificate -> m [FailedReason]
doCheckCertificate Certificate
cert =
            Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
forall (m :: * -> *).
Monad m =>
Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
exhaustiveList (ValidationChecks -> Bool
checkExhaustive ValidationChecks
checks)
                [ (ValidationChecks -> Bool
checkTimeValidity ValidationChecks
checks, [FailedReason] -> m [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return ((ValidationHooks -> DateTime -> Certificate -> [FailedReason]
hookValidateTime ValidationHooks
hooks) DateTime
validationTime Certificate
cert))
                ]
        isSelfSigned :: Certificate -> Bool
        isSelfSigned :: Certificate -> Bool
isSelfSigned Certificate
cert = Certificate -> DistinguishedName
certSubjectDN Certificate
cert DistinguishedName -> DistinguishedName -> Bool
forall a. Eq a => a -> a -> Bool
== Certificate -> DistinguishedName
certIssuerDN Certificate
cert

        -- 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 String, [String])
getNames Certificate
cert = (Maybe ASN1CharacterString
commonName Maybe ASN1CharacterString
-> (ASN1CharacterString -> Maybe String) -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ASN1CharacterString -> Maybe String
asn1CharacterToString, [String]
altNames)
  where commonName :: Maybe ASN1CharacterString
commonName = DnElement -> DistinguishedName -> Maybe ASN1CharacterString
getDnElement DnElement
DnCommonName (DistinguishedName -> Maybe ASN1CharacterString)
-> DistinguishedName -> Maybe ASN1CharacterString
forall a b. (a -> b) -> a -> b
$ Certificate -> DistinguishedName
certSubjectDN Certificate
cert
        altNames :: [String]
altNames   = [String]
-> (ExtSubjectAltName -> [String])
-> Maybe ExtSubjectAltName
-> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ExtSubjectAltName -> [String]
toAltName (Maybe ExtSubjectAltName -> [String])
-> Maybe ExtSubjectAltName -> [String]
forall a b. (a -> b) -> a -> b
$ Extensions -> Maybe ExtSubjectAltName
forall a. Extension a => Extensions -> Maybe a
extensionGet (Extensions -> Maybe ExtSubjectAltName)
-> Extensions -> Maybe ExtSubjectAltName
forall a b. (a -> b) -> a -> b
$ Certificate -> Extensions
certExtensions Certificate
cert
        toAltName :: ExtSubjectAltName -> [String]
toAltName (ExtSubjectAltName [AltName]
names) = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall a b. (a -> b) -> a -> b
$ (AltName -> Maybe String) -> [AltName] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map AltName -> Maybe String
unAltName [AltName]
names
            where unAltName :: AltName -> Maybe String
unAltName (AltNameDNS String
s) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
                  unAltName AltName
_              = Maybe String
forall a. Maybe a
Nothing

-- | 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 :: String -> Certificate -> [FailedReason]
validateCertificateName String
fqhn Certificate
cert
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
altNames =
        [FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch [] ([[FailedReason]] -> [FailedReason])
-> [[FailedReason]] -> [FailedReason]
forall a b. (a -> b) -> a -> b
$ (String -> [FailedReason]) -> [String] -> [[FailedReason]]
forall a b. (a -> b) -> [a] -> [b]
map String -> [FailedReason]
matchDomain [String]
altNames
    | Bool
otherwise =
        case Maybe String
commonName of
            Maybe String
Nothing -> [FailedReason
NoCommonName]
            Just String
cn -> [FailedReason] -> [[FailedReason]] -> [FailedReason]
findMatch [] ([[FailedReason]] -> [FailedReason])
-> [[FailedReason]] -> [FailedReason]
forall a b. (a -> b) -> a -> b
$ [String -> [FailedReason]
matchDomain String
cn]
  where (Maybe String
commonName, [String]
altNames) = Certificate -> (Maybe String, [String])
getNames Certificate
cert

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

        matchDomain :: String -> [FailedReason]
        matchDomain :: String -> [FailedReason]
matchDomain String
name = case String -> [String]
splitDot String
name of
            [String]
l | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"") [String]
l       -> [String -> FailedReason
InvalidName String
name]
              | [String] -> String
forall a. [a] -> a
head [String]
l String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"*"       -> [String] -> [FailedReason]
wildcardMatch (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
l)
              | [String]
l [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== String -> [String]
splitDot String
fqhn  -> [] -- 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 (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 :: Monad m => Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
exhaustive :: Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
exhaustive Bool
isExhaustive m [FailedReason]
f1 m [FailedReason]
f2 = m [FailedReason]
f1 m [FailedReason]
-> ([FailedReason] -> m [FailedReason]) -> m [FailedReason]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [FailedReason] -> m [FailedReason]
cont
  where cont :: [FailedReason] -> m [FailedReason]
cont [FailedReason]
l1
            | [FailedReason] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FailedReason]
l1      = m [FailedReason]
f2
            | Bool
isExhaustive = m [FailedReason]
f2 m [FailedReason]
-> ([FailedReason] -> m [FailedReason]) -> m [FailedReason]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[FailedReason]
l2 -> [FailedReason] -> m [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FailedReason]
l1 [FailedReason] -> [FailedReason] -> [FailedReason]
forall a. [a] -> [a] -> [a]
++ [FailedReason]
l2)
            | Bool
otherwise    = [FailedReason] -> m [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return [FailedReason]
l1

exhaustiveList :: Monad m => Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
exhaustiveList :: Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
exhaustiveList Bool
_            []                    = [FailedReason] -> m [FailedReason]
forall (m :: * -> *) a. Monad m => a -> m a
return []
exhaustiveList Bool
isExhaustive ((Bool
performCheck,m [FailedReason]
c):[(Bool, m [FailedReason])]
cs)
    | Bool
performCheck = Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
forall (m :: * -> *).
Monad m =>
Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
exhaustive Bool
isExhaustive m [FailedReason]
c (Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
forall (m :: * -> *).
Monad m =>
Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
exhaustiveList Bool
isExhaustive [(Bool, m [FailedReason])]
cs)
    | Bool
otherwise    = Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
forall (m :: * -> *).
Monad m =>
Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]
exhaustiveList Bool
isExhaustive [(Bool, m [FailedReason])]
cs