Validation.hs

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

import Control.Applicative
import Control.Monad (when)
import Data.Default.Class
import Data.ASN1.Types
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.Time.Clock
import Data.Maybe
import Data.List

-- | Possible reason of certificate and chain failure
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 (Show,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
      checkTimeValidity   :: Bool
    -- | The time when the validity check happens. When set to Nothing,
    -- the current time will be used
    , checkAtTime         :: Maybe UTCTime
    -- | 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.
    , checkStrictOrdering :: Bool
    -- | Check that signing certificate got the CA basic constraint.
    -- this is absolutely not recommended to turn it off.
    , 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.
    , 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.
    , 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.
    , 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.
    , 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.
    , checkFQHN           :: Bool
    } deriving (Show,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 the the issuer 'DistinguishedName' match the subject 'DistinguishedName'
    -- of a certificate.
      hookMatchSubjectIssuer :: DistinguishedName -> Certificate -> Bool
    -- | validate that the parametrized time valide with the certificate in argument
    , hookValidateTime       :: UTCTime -> Certificate -> [FailedReason]
    -- | validate the certificate leaf name with the DNS named used to connect
    , hookValidateName       :: HostName -> Certificate -> [FailedReason]
    -- | user filter to modify the list of failure reasons
    , 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
    { checkTimeValidity   = True
    , checkAtTime         = Nothing
    , checkStrictOrdering = False
    , checkCAConstraints  = True
    , checkExhaustive     = False
    , checkLeafV3         = True
    , checkLeafKeyUsage   = []
    , checkLeafKeyPurpose = []
    , checkFQHN           = True
    }

instance Default ValidationChecks where
    def = defaultChecks

-- | Default hooks in the validation process
defaultHooks :: ValidationHooks
defaultHooks = ValidationHooks
    { hookMatchSubjectIssuer = matchSI
    , hookValidateTime       = validateTime
    , hookValidateName       = validateCertificateName
    , hookFilterReason       = id
    }

instance Default ValidationHooks where
    def = 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 = validate HashSHA256 defaultHooks 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 _ _ _ _ _ _ (CertificateChain []) = return [EmptyChain]
validate hashAlg hooks checks store cache ident cc@(CertificateChain (top:_)) = do
    cacheResult <- (cacheQuery cache) ident fingerPrint (getCertificate top)
    case cacheResult of
        ValidationCachePass     -> return []
        ValidationCacheDenied s -> return [CacheSaysNo s]
        ValidationCacheUnknown  -> do
            validationTime <- maybe getCurrentTime return $ checkAtTime checks
            failedReasons <- doValidate validationTime hooks checks store ident cc
            when (null failedReasons) $ (cacheAdd cache) ident fingerPrint (getCertificate top)
            return failedReasons
  where fingerPrint = getFingerprint top hashAlg


-- | Validate a certificate chain with explicit parameters
doValidate :: UTCTime
           -> ValidationHooks
           -> ValidationChecks
           -> CertificateStore
           -> ServiceID
           -> CertificateChain
           -> IO [FailedReason]
doValidate _              _     _      _     _        (CertificateChain [])           = return [EmptyChain]
doValidate validationTime hooks checks store (fqhn,_) (CertificateChain (top:rchain)) =
   (hookFilterReason hooks) <$> (return doLeafChecks |> doCheckChain 0 top rchain)
  where isExhaustive = checkExhaustive checks
        a |> b = exhaustive isExhaustive a b

        doLeafChecks = doNameCheck top ++ doV3Check topCert ++ doKeyUsageCheck topCert
            where topCert = getCertificate top

        doCheckChain :: Int -> SignedCertificate -> [SignedCertificate] -> IO [FailedReason]
        doCheckChain level current chain = do
            r <- doCheckCertificate (getCertificate current)
            -- check if we have a trusted certificate in the store belonging to this issuer.
            return r |> (case findCertificate (certIssuerDN cert) store of
                Just trustedSignedCert      -> return $ checkSignature current trustedSignedCert
                Nothing | isSelfSigned cert -> return [SelfSigned] |> return (checkSignature current current)
                        | null chain        -> return [UnknownCA]
                        | otherwise         ->
                            case findIssuer (certIssuerDN cert) chain of
                                Nothing                  -> return [UnknownCA]
                                Just (issuer, remaining) ->
                                    return (checkCA level $ getCertificate issuer)
                                    |> return (checkSignature current issuer)
                                    |> doCheckChain (level+1) issuer remaining)
          where cert = getCertificate 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 issuerDN chain
            | checkStrictOrdering checks =
                case chain of
                    []     -> error "not possible"
                    (c:cs) | matchSubjectIdentifier issuerDN (getCertificate c) -> Just (c, cs)
                           | otherwise                                          -> Nothing
            | otherwise =
                (\x -> (x, filter (/= x) chain)) `fmap` find (matchSubjectIdentifier issuerDN . getCertificate) chain
        matchSubjectIdentifier = hookMatchSubjectIssuer 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 level cert
            | not (checkCAConstraints checks)          = []
            | and [allowedSign,allowedCA,allowedDepth] = []
            | otherwise = (if allowedSign then [] else [NotAllowedToSign])
                       ++ (if allowedCA   then [] else [NotAnAuthority])
                       ++ (if allowedDepth then [] else [AuthorityTooDeep])
          where extensions  = certExtensions cert
                allowedSign = case extensionGet extensions of
                                Just (ExtKeyUsage flags) -> KeyUsage_keyCertSign `elem` flags
                                Nothing                  -> True
                (allowedCA,pathLen) = case extensionGet extensions of
                                Just (ExtBasicConstraints True pl) -> (True, pl)
                                _                                  -> (False, Nothing)
                allowedDepth = case pathLen of
                                    Nothing                            -> True
                                    Just pl | fromIntegral pl >= level -> True
                                            | otherwise                -> False

        doNameCheck cert
            | not (checkFQHN checks) = []
            | otherwise              = (hookValidateName hooks) fqhn (getCertificate cert)

        doV3Check cert
            | checkLeafV3 checks = case certVersion cert of
                                        2 {- confusingly it means X509.V3 -} -> []
                                        _ -> [LeafNotV3]
            | otherwise = []

        doKeyUsageCheck cert =
               compareListIfExistAndNotNull mflags (checkLeafKeyUsage checks) LeafKeyUsageNotAllowed
            ++ compareListIfExistAndNotNull mpurposes (checkLeafKeyPurpose checks) LeafKeyPurposeNotAllowed
          where mflags = case extensionGet $ certExtensions cert of
                            Just (ExtKeyUsage keyflags) -> Just keyflags
                            Nothing                     -> Nothing
                mpurposes = case extensionGet $ certExtensions cert of
                            Just (ExtExtendedKeyUsage keyPurposes) -> Just keyPurposes
                            Nothing                                -> 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 Nothing     _        _   = []
                compareListIfExistAndNotNull (Just list) expected err
                    | null expected                       = []
                    | intersect expected list == expected = []
                    | otherwise                           = [err]

        doCheckCertificate cert =
            exhaustiveList (checkExhaustive checks)
                [ (checkTimeValidity checks, return ((hookValidateTime hooks) validationTime cert))
                ]
        isSelfSigned :: Certificate -> Bool
        isSelfSigned cert = certSubjectDN cert == certIssuerDN cert

        -- check signature of 'signedCert' against the 'signingCert'
        checkSignature signedCert signingCert =
            case verifySignedSignature signedCert (certPubKey $ getCertificate signingCert) of
                SignaturePass     -> []
                SignatureFailed r -> [InvalidSignature r]

-- | Validate that the current time is between validity bounds
validateTime :: UTCTime -> Certificate -> [FailedReason]
validateTime currentTime cert
    | currentTime < before = [InFuture]
    | currentTime > after  = [Expired]
    | otherwise            = []
  where (before, after) = certValidity cert

getNames :: Certificate -> (Maybe String, [String])
getNames cert = (commonName >>= asn1CharacterToString, altNames)
  where commonName = getDnElement DnCommonName $ certSubjectDN cert
        altNames   = maybe [] toAltName $ extensionGet $ certExtensions cert
        toAltName (ExtSubjectAltName names) = catMaybes $ map unAltName names
            where unAltName (AltNameDNS s) = Just s
                  unAltName _              = Nothing

-- | Validate that the fqhn is matched by at least one name in the certificate.
-- The name can be either the common name or one of the alternative names if
-- the SubjectAltName extension is present.
validateCertificateName :: HostName -> Certificate -> [FailedReason]
validateCertificateName fqhn cert =
    case commonName of
        Nothing -> [NoCommonName]
        Just cn -> findMatch [] $ map (matchDomain . splitDot) (cn : altNames)
  where (commonName, altNames) = getNames cert

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

        matchDomain :: [String] -> [FailedReason]
        matchDomain l
            | length (filter (== "") l) > 0 = [InvalidName (intercalate "." l)]
            | head l == "*"                 = wildcardMatch (reverse $ drop 1 l)
            | l == splitDot fqhn            = [] -- success: we got a match
            | otherwise                     = [NameMismatch fqhn]

        -- only 1 wildcard is valid, and 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
        wildcardMatch l
            -- <star>.com or <star> is always invalid
            | length l < 2 = [InvalidWildcard]
            -- some TLD like .uk got small subTLD like (.co.uk), and we don't want to accept *.co.uk
            | length (head l) <= 2 && length (head $ drop 1 l) <= 3 && length l < 3 = [InvalidWildcard]
            | l == take (length l) (reverse $ splitDot fqhn) = [] -- success: we got a match
            | otherwise                                      = [NameMismatch fqhn]

        splitDot :: String -> [String]
        splitDot [] = [""]
        splitDot x  =
            let (y, z) = break (== '.') x in
            y : (if z == "" then [] else splitDot $ drop 1 z)


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

exhaustive :: Monad m => Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]
exhaustive isExhaustive f1 f2 = f1 >>= cont
  where cont l1
            | null l1      = f2
            | isExhaustive = f2 >>= \l2 -> return (l1 ++ l2)
            | otherwise    = return l1

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