diff --git a/Data/X509/Validation.hs b/Data/X509/Validation.hs --- a/Data/X509/Validation.hs +++ b/Data/X509/Validation.hs @@ -10,10 +10,14 @@ -- Follows RFC5280 / RFC6818 -- module Data.X509.Validation - ( FailedReason(..) + ( FQHN + , FailedReason(..) + , SignatureFailure(..) , Parameters(..) , Checks(..) + , Hooks(..) , defaultChecks + , defaultHooks , validate , validateWith , getFingerprint @@ -29,6 +33,9 @@ import Data.Maybe import Data.List +-- | a Fully Qualified Host Name, e.g. www.example.com +type FQHN = String + -- | Possible reason of certificate and chain failure data FailedReason = UnknownCriticalExtension -- ^ certificate contains an unknown critical extension @@ -38,7 +45,7 @@ | UnknownCA -- ^ unknown Certificate Authority (CA) | NotAllowedToSign -- ^ certificate is not allowed to sign | NotAnAuthority -- ^ not a CA - | InvalidSignature -- ^ signature failed + | 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 @@ -47,6 +54,7 @@ | 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 + | InvalidSignature SignatureFailure -- ^ signature failed deriving (Show,Eq) -- | A set of checks to activate or parametrize to perform on certificates. @@ -89,21 +97,40 @@ , 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 :: Maybe String + , checkFQHN :: Bool } deriving (Show,Eq) --- | Validation parameters +-- | A set of hooks to manipulate the way the verification works. +-- +-- BEWARE, it's easy to change behavior leading to compromised security. +data Hooks = Hooks + { + -- | 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 :: FQHN -> Certificate -> [FailedReason] + } + +-- | Validation parameters. List all the conditions where/when we want the certificate checks +-- to happen. data Parameters = Parameters - { parameterTime :: UTCTime + { parameterTime :: UTCTime -- ^ the time when we want the certificate check to happen. + -- usually should be the time as of now. + , parameterFQHN :: FQHN -- ^ fqhn to match } 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 +-- 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 :: Checks +defaultChecks = Checks { checkTimeValidity = True , checkStrictOrdering = False , checkCAConstraints = True @@ -111,25 +138,33 @@ , checkLeafV3 = True , checkLeafKeyUsage = [] , checkLeafKeyPurpose = [] - , checkFQHN = fqhn + , checkFQHN = True } +-- | Default hooks in the validation process +defaultHooks :: Hooks +defaultHooks = Hooks + { hookMatchSubjectIssuer = matchSI + , hookValidateTime = validateTime + , hookValidateName = validateCertificateName + } + -- | 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 :: Hooks -> Checks -> CertificateStore -> FQHN -> CertificateChain -> IO [FailedReason] +validate _ _ _ _ (CertificateChain []) = return [EmptyChain] +validate hooks checks store fqhn cc@(CertificateChain (_:_)) = do + params <- Parameters <$> getCurrentTime <*> pure fqhn + validateWith params hooks checks store 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)) = +validateWith :: Parameters -> Hooks -> Checks -> CertificateStore -> CertificateChain -> IO [FailedReason] +validateWith _ _ _ _ (CertificateChain []) = return [EmptyChain] +validateWith params hooks checks store (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 + doLeafChecks = doNameCheck top |> doV3Check topCert |> doKeyUsageCheck topCert where topCert = getCertificate top doCheckChain :: Int -> SignedCertificate -> [SignedCertificate] -> IO [FailedReason] @@ -144,7 +179,7 @@ case findIssuer (certIssuerDN cert) chain of Nothing -> return [UnknownCA] Just (issuer, remaining) -> - return (checkCA $ getCertificate issuer) + return (checkCA level $ getCertificate issuer) |> return (checkSignature current issuer) |> doCheckChain (level+1) issuer remaining) where cert = getCertificate current @@ -154,31 +189,40 @@ | checkStrictOrdering checks = case chain of [] -> error "not possible" - (c:cs) | matchSI issuerDN c -> Just (c, cs) - | otherwise -> Nothing + (c:cs) | matchSubjectIdentifier issuerDN (getCertificate c) -> Just (c, cs) + | otherwise -> Nothing | otherwise = - (\x -> (x, filter (/= x) chain)) `fmap` find (matchSI issuerDN) chain + (\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 :: Certificate -> [FailedReason] - checkCA cert - | allowedSign && allowedCA = [] - | otherwise = (if allowedSign then [] else [NotAllowedToSign]) - ++ (if allowedCA then [] else [NotAnAuthority]) + 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 = case extensionGet extensions of - Just (ExtBasicConstraints True _) -> True - _ -> False + (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 Nothing _ = return [] - doNameCheck (Just fqhn) cert = return (validateCertificateName fqhn (getCertificate cert)) + doNameCheck cert + | not (checkFQHN checks) = return [] + | otherwise = return $ (hookValidateName hooks) fqhn (getCertificate cert) + where fqhn = parameterFQHN params doV3Check cert | checkLeafV3 checks = case certVersion cert of @@ -206,7 +250,7 @@ doCheckCertificate cert = exhaustiveList (checkExhaustive checks) - [ (checkTimeValidity checks, return (validateTime (parameterTime params) cert)) + [ (checkTimeValidity checks, return ((hookValidateTime hooks) (parameterTime params) cert)) ] isSelfSigned :: Certificate -> Bool isSelfSigned cert = certSubjectDN cert == certIssuerDN cert @@ -214,8 +258,8 @@ -- check signature of 'signedCert' against the 'signingCert' checkSignature signedCert signingCert = case verifySignedSignature signedCert (certPubKey $ getCertificate signingCert) of - SignaturePass -> [] - _ -> [InvalidSignature] + SignaturePass -> [] + SignatureFailed r -> [InvalidSignature r] -- | Validate that the current time is between validity bounds validateTime :: UTCTime -> Certificate -> [FailedReason] @@ -236,7 +280,7 @@ -- | 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 -> Certificate -> [FailedReason] validateCertificateName fqhn cert = case commonName of Nothing -> [NoCommonName] @@ -277,8 +321,8 @@ -- | 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 +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 diff --git a/Data/X509/Validation/Signature.hs b/Data/X509/Validation/Signature.hs --- a/Data/X509/Validation/Signature.hs +++ b/Data/X509/Validation/Signature.hs @@ -11,6 +11,7 @@ ( verifySignedSignature , verifySignature , SignatureVerification(..) + , SignatureFailure(..) ) where import qualified Crypto.PubKey.RSA.PKCS15 as RSA @@ -26,14 +27,20 @@ -- | A set of possible return from signature verification. -- --- Only SignaturePass should be accepted as success. +-- When SignatureFailed is return, the signature shouldn't be +-- accepted. -- -- Other values are only useful to differentiate the failure -- reason, but are all equivalent to failure. -- data SignatureVerification = - SignaturePass -- ^ verification succeeded - | SignatureFailed -- ^ verification failed + SignaturePass -- ^ verification succeeded + | SignatureFailed SignatureFailure -- ^ verification failed + deriving (Show,Eq) + +-- | Various failure possible during signature checking +data SignatureFailure = + SignatureInvalid -- ^ signature doesn't verify | SignaturePubkeyMismatch -- ^ algorithm and public key mismatch, cannot proceed | SignatureUnimplemented -- ^ unimplemented signature algorithm deriving (Show,Eq) @@ -56,14 +63,14 @@ -> ByteString -- ^ Certificate data that need to be verified -> ByteString -- ^ Signature to verify -> SignatureVerification -verifySignature (SignatureALG_Unknown _) _ _ _ = SignatureUnimplemented +verifySignature (SignatureALG_Unknown _) _ _ _ = SignatureFailed SignatureUnimplemented verifySignature (SignatureALG hashALG pubkeyALG) pubkey cdata signature | pubkeyToAlg pubkey == pubkeyALG = case verifyF pubkey of - Nothing -> SignatureUnimplemented + Nothing -> SignatureFailed SignatureUnimplemented Just f -> if f cdata signature then SignaturePass - else SignatureFailed - | otherwise = SignaturePubkeyMismatch + else SignatureFailed SignatureInvalid + | otherwise = SignatureFailed SignaturePubkeyMismatch where verifyF (PubKeyRSA key) = Just $ RSA.verify (toDescr hashALG) key verifyF (PubKeyDSA key) diff --git a/x509-validation.cabal b/x509-validation.cabal --- a/x509-validation.cabal +++ b/x509-validation.cabal @@ -1,5 +1,5 @@ Name: x509-validation -Version: 1.4.7 +Version: 1.4.8 Description: X.509 Certificate and CRL validation License: BSD3 License-file: LICENSE