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
data FailedReason =
UnknownCriticalExtension
| Expired
| InFuture
| SelfSigned
| UnknownCA
| NotAllowedToSign
| NotAnAuthority
| InvalidSignature
| NoCommonName
| InvalidName String
| NameMismatch String
| InvalidWildcard
| LeafKeyUsageNotAllowed
| LeafNotV3
| EmptyChain
deriving (Show,Eq)
data Checks = Checks
{
checkTimeValidity :: Bool
, checkStrictOrdering :: Bool
, checkCAConstraints :: Bool
, checkExhaustive :: Bool
, checkLeafV3 :: Bool
, checkLeafKeyUsage :: [ExtKeyUsageFlag]
, checkFQHN :: Maybe String
} deriving (Show,Eq)
data Parameters = Parameters
{ parameterTime :: UTCTime
} deriving (Show,Eq)
defaultChecks :: Maybe String
-> Checks
defaultChecks fqhn = Checks
{ checkTimeValidity = True
, checkStrictOrdering = False
, checkCAConstraints = True
, checkExhaustive = False
, checkLeafV3 = True
, checkLeafKeyUsage = [KeyUsage_keyEncipherment]
, checkFQHN = fqhn
}
validate :: Checks -> CertificateStore -> CertificateChain -> IO [FailedReason]
validate _ _ (CertificateChain []) = return [EmptyChain]
validate checks store cc@(CertificateChain (_:_)) = do
params <- Parameters <$> getCurrentTime
validateWith params store checks cc
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)
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
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
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 -> 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
checkSignature signedCert signingCert =
case verifySignedSignature signedCert (certPubKey $ getCertificate signingCert) of
SignaturePass -> []
_ -> [InvalidSignature]
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
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 = []
| otherwise = [NameMismatch fqhn]
wildcardMatch l
| length l < 2 = [InvalidWildcard]
| length (head l) <= 2 && length (head $ drop 1 l) <= 3 && length l < 3 = [InvalidWildcard]
| l == take (length l) (reverse $ splitDot fqhn) = []
| otherwise = [NameMismatch fqhn]
splitDot :: String -> [String]
splitDot [] = [""]
splitDot x =
let (y, z) = break (== '.') x in
y : (if z == "" then [] else splitDot $ drop 1 z)
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