x509-validation-1.4.6: Data/X509/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
( FailedReason(..)
, Parameters(..)
, Checks(..)
, defaultChecks
, validate
, validateWith
, getFingerprint
) where
import Control.Applicative
import Data.ASN1.Types
import Data.X509
import Data.X509.CertificateStore
import Data.X509.Validation.Signature
import Data.X509.Validation.Fingerprint
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
| InvalidSignature -- ^ signature failed
| 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
| LeafNotV3 -- ^ Only authorized an X509.V3 certificate as leaf certificate.
| EmptyChain -- ^ empty chain of certificate
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 Checks = Checks
{
-- | 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
-- | 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
, checkLeafKeyUsage :: [ExtKeyUsageFlag]
-- | 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 :: Maybe String
} deriving (Show,Eq)
-- | Validation parameters
data Parameters = Parameters
{ parameterTime :: UTCTime
} deriving (Show,Eq)
-- | Default checks to perform
--
-- It's not recommended to use Nothing as FQDN, doing so
-- will ignore an important validation parameter check.
defaultChecks :: Maybe String -- ^ fully qualified host name that we need to match in the certificate
-> Checks
defaultChecks fqhn = Checks
{ checkTimeValidity = True
, checkStrictOrdering = False
, checkCAConstraints = True
, checkExhaustive = False
, checkLeafV3 = True
, checkLeafKeyUsage = [KeyUsage_keyEncipherment]
, checkFQHN = fqhn
}
-- | validate a certificate chain.
validate :: Checks -> CertificateStore -> CertificateChain -> IO [FailedReason]
validate _ _ (CertificateChain []) = return [EmptyChain]
validate checks store cc@(CertificateChain (_:_)) = do
params <- Parameters <$> getCurrentTime
validateWith params store checks cc
-- | Validate a certificate chain with explicit parameters
validateWith :: Parameters -> CertificateStore -> Checks -> CertificateChain -> IO [FailedReason]
validateWith _ _ _ (CertificateChain []) = return [EmptyChain]
validateWith params store checks (CertificateChain (top:rchain)) =
doLeafChecks |> doCheckChain 0 top rchain
where isExhaustive = checkExhaustive checks
a |> b = exhaustive isExhaustive a b
doLeafChecks = doNameCheck (checkFQHN checks) 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 $ 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) | matchSI issuerDN c -> Just (c, cs)
| otherwise -> Nothing
| otherwise =
(\x -> (x, filter (/= x) chain)) `fmap` find (matchSI issuerDN) chain
-- 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 :: Certificate -> [FailedReason]
checkCA cert
| allowedSign && allowedCA = []
| otherwise = (if allowedSign then [] else [NotAllowedToSign])
++ (if allowedCA then [] else [NotAnAuthority])
where extensions = certExtensions cert
allowedSign = case extensionGet extensions of
Just (ExtKeyUsage flags) -> KeyUsage_keyCertSign `elem` flags
Nothing -> True
allowedCA = case extensionGet extensions of
Just (ExtBasicConstraints True _) -> True
_ -> False
doNameCheck Nothing _ = return []
doNameCheck (Just fqhn) cert = return (validateCertificateName fqhn (getCertificate cert))
doV3Check cert
| checkLeafV3 checks = case certVersion cert of
2 {- confusingly it means X509.V3 -} -> return []
_ -> return [LeafNotV3]
| otherwise = return []
doKeyUsageCheck cert = return $
case (certVersion cert, checkLeafKeyUsage checks) of
(2, usage) -> if intersect usage flags == usage then [] else [LeafKeyUsageNotAllowed]
_ -> []
where flags = case extensionGet $ certExtensions cert of
Just (ExtKeyUsage keyflags) -> keyflags
Nothing -> []
doCheckCertificate cert =
exhaustiveList (checkExhaustive checks)
[ (checkTimeValidity checks, return (validateTime (parameterTime params) 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 -> []
_ -> [InvalidSignature]
-- | 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 :: String -> 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 subTLS 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 -> SignedCertificate -> Bool
matchSI issuerDN issuer = certSubjectDN (getCertificate 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