diff --git a/Data/X509/Validation.hs b/Data/X509/Validation.hs --- a/Data/X509/Validation.hs +++ b/Data/X509/Validation.hs @@ -8,134 +8,154 @@ -- X.509 Certificate checks and validations routines -- -- Follows RFC5280 / RFC6818 --- -module Data.X509.Validation - ( - module Data.X509.Validation.Types - , Fingerprint(..) +module Data.X509.Validation ( + module Data.X509.Validation.Types, + Fingerprint (..), + -- * Failed validation types - , FailedReason(..) - , SignatureFailure(..) + FailedReason (..), + SignatureFailure (..), + -- * Validation configuration types - , ValidationChecks(..) - , ValidationHooks(..) - , defaultChecks - , defaultHooks + ValidationChecks (..), + ValidationHooks (..), + defaultChecks, + defaultHooks, + -- * Validation - , validate - , validatePure - , validateDefault - , getFingerprint + validate, + validatePure, + validateDefault, + getFingerprint, + -- * Cache - , module Data.X509.Validation.Cache + module Data.X509.Validation.Cache, + -- * Signature verification - , module Data.X509.Validation.Signature - ) where + 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.Default +import Data.Hourglass +import Data.List +import Data.Maybe 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.Fingerprint +import Data.X509.Validation.Signature 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 (Show,Eq) +data FailedReason + = -- | certificate contains an unknown critical extension + UnknownCriticalExtension + | -- | validity ends before checking time + Expired + | -- | validity starts after checking time + InFuture + | -- | certificate is self signed + SelfSigned + | -- | unknown Certificate Authority (CA) + UnknownCA + | -- | certificate is not allowed to sign + NotAllowedToSign + | -- | not a CA + NotAnAuthority + | -- | Violation of the optional Basic constraint's path length + AuthorityTooDeep + | -- | Certificate doesn't have any common name (CN) + NoCommonName + | -- | Invalid name in certificate + InvalidName String + | -- | connection name and certificate do not match + NameMismatch String + | -- | invalid wildcard in certificate + InvalidWildcard + | -- | the requested key usage is not compatible with the leaf certificate's key usage + LeafKeyUsageNotAllowed + | -- | the requested key purpose is not compatible with the leaf certificate's extended key usage + LeafKeyPurposeNotAllowed + | -- | Only authorized an X509.V3 certificate as leaf certificate. + LeafNotV3 + | -- | empty chain of certificate + EmptyChain + | -- | the cache explicitely denied this certificate + CacheSaysNo String + | -- | signature failed + InvalidSignature SignatureFailure + 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. + { checkTimeValidity :: Bool + -- ^ 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, + , checkAtTime :: Maybe DateTime + -- ^ The time when the validity check happens. When set to Nothing, -- the current time will be used - , checkAtTime :: Maybe DateTime - -- | Check that no certificate is included that shouldn't be included. + , checkStrictOrdering :: 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. + , checkCAConstraints :: 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. + , checkExhaustive :: 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 + , checkLeafV3 :: 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. + , checkLeafKeyUsage :: [ExtKeyUsageFlag] + -- ^ 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. + , checkLeafKeyPurpose :: [ExtKeyUsagePurpose] + -- ^ 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). + , checkFQHN :: Bool + -- ^ 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) + } + 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 whether a given issuer 'DistinguishedName' matches the subject + { hookMatchSubjectIssuer :: DistinguishedName -> Certificate -> Bool + -- ^ check whether a given issuer 'DistinguishedName' matches the subject -- 'DistinguishedName' of a candidate issuer certificate. - hookMatchSubjectIssuer :: DistinguishedName -> Certificate -> Bool - -- | check whether the certificate in the second argument is valid at the + , hookValidateTime :: DateTime -> Certificate -> [FailedReason] + -- ^ 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. - , hookValidateTime :: DateTime -> 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] + , hookValidateName :: HostName -> Certificate -> [FailedReason] + -- ^ validate the certificate leaf name with the DNS named used to connect + , hookFilterReason :: [FailedReason] -> [FailedReason] + -- ^ user filter to modify the list of failure reasons } -- | Default checks to perform @@ -146,39 +166,47 @@ -- * 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 - } +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 - } +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 + :: 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 @@ -186,153 +214,194 @@ -- 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 + -- ^ 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 +validate hashAlg hooks checks store cache ident cc@(CertificateChain (top : _)) = do cacheResult <- (cacheQuery cache) ident fingerPrint (getCertificate top) case cacheResult of - ValidationCachePass -> return [] + ValidationCachePass -> return [] ValidationCacheDenied s -> return [CacheSaysNo s] - ValidationCacheUnknown -> do - validationTime <- maybe (timeConvert <$> timeCurrent) return $ checkAtTime checks + ValidationCacheUnknown -> do + validationTime <- + maybe (timeConvert <$> timeCurrent) return $ checkAtTime checks let failedReasons = validatePure validationTime hooks checks store ident cc - when (null failedReasons) $ (cacheAdd cache) ident fingerPrint (getCertificate top) + when (null failedReasons) $ + (cacheAdd cache) ident fingerPrint (getCertificate top) return failedReasons - where fingerPrint = getFingerprint top hashAlg - + where + fingerPrint = getFingerprint top hashAlg -- | Validate a certificate chain with explicit pure parameters -validatePure :: DateTime -- ^ The time for which to check validity for - -> ValidationHooks -- ^ Hooks to use - -> ValidationChecks -- ^ Checks to do - -> CertificateStore -- ^ The trusted certificate store for CA - -> ServiceID -- ^ Identification of the connection - -> CertificateChain -- ^ The certificate chain we want to validate - -> [FailedReason] -- ^ the return failed reasons (empty list is no failure) -validatePure _ _ _ _ _ (CertificateChain []) = [EmptyChain] -validatePure validationTime hooks checks store (fqhn,_) (CertificateChain (top:rchain)) = - hookFilterReason hooks (doLeafChecks |> doCheckChain 0 top rchain) - where isExhaustive = checkExhaustive checks - a |> b = exhaustive isExhaustive a b +validatePure + :: DateTime + -- ^ The time for which to check validity for + -> ValidationHooks + -- ^ Hooks to use + -> ValidationChecks + -- ^ Checks to do + -> CertificateStore + -- ^ The trusted certificate store for CA + -> ServiceID + -- ^ Identification of the connection + -> CertificateChain + -- ^ The certificate chain we want to validate + -> [FailedReason] + -- ^ the return failed reasons (empty list is no failure) +validatePure _ _ _ _ _ (CertificateChain []) = [EmptyChain] +validatePure validationTime hooks checks store (fqhn, _) (CertificateChain (top : rchain)) = + hookFilterReason hooks (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 + doLeafChecks = doNameCheck top ++ doV3Check topCert ++ doKeyUsageCheck topCert + where + topCert = getCertificate top - doCheckChain :: Int -> SignedCertificate -> [SignedCertificate] -> [FailedReason] - doCheckChain level current chain = - doCheckCertificate (getCertificate current) + doCheckChain + :: Int -> SignedCertificate -> [SignedCertificate] -> [FailedReason] + doCheckChain level current chain = + doCheckCertificate (getCertificate current) -- check if we have a trusted certificate in the store belonging to this issuer. - |> (case findCertificate (certIssuerDN cert) store of - Just trustedSignedCert -> checkSignature current trustedSignedCert - Nothing | isSelfSigned cert -> [SelfSigned] |> checkSignature current current - | null chain -> [UnknownCA] - | otherwise -> + |> ( case findCertificate (certIssuerDN cert) store of + Just trustedSignedCert -> checkSignature current trustedSignedCert + Nothing + | isSelfSigned cert -> [SelfSigned] |> checkSignature current current + | null chain -> [UnknownCA] + | otherwise -> case findIssuer (certIssuerDN cert) chain of - Nothing -> [UnknownCA] + Nothing -> [UnknownCA] Just (issuer, remaining) -> checkCA level (getCertificate issuer) - |> 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 + |> 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 + -- 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) + 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 = [] + 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] + 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, hookValidateTime hooks validationTime cert) - ] - isSelfSigned :: Certificate -> Bool - isSelfSigned cert = certSubjectDN cert == certIssuerDN cert + doCheckCertificate cert = + exhaustiveList + (checkExhaustive checks) + [ (checkTimeValidity checks, 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] + -- 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 :: DateTime -> Certificate -> [FailedReason] validateTime currentTime cert | currentTime < before = [InFuture] - | currentTime > after = [Expired] - | otherwise = [] - where (before, after) = certValidity cert + | 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 + 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. -- If the subjectAltname extension is present, then the certificate commonName @@ -350,43 +419,44 @@ case commonName of Nothing -> [NoCommonName] Just cn -> findMatch [] $ [matchDomain cn] - where (commonName, altNames) = getNames cert - - findMatch :: [FailedReason] -> [[FailedReason]] -> [FailedReason] - findMatch _ [] = [NameMismatch fqhn] - findMatch _ ([]:_) = [] - findMatch acc (_ :xs) = findMatch acc xs + where + (commonName, altNames) = getNames cert - matchDomain :: String -> [FailedReason] - matchDomain name = case splitDot name of - l | any (== "") l -> [InvalidName name] - | head l == "*" -> wildcardMatch (drop 1 l) - | l == splitDot fqhn -> [] -- success: we got a match - | otherwise -> [NameMismatch fqhn] + findMatch :: [FailedReason] -> [[FailedReason]] -> [FailedReason] + findMatch _ [] = [NameMismatch fqhn] + findMatch _ ([] : _) = [] + findMatch acc (_ : xs) = findMatch acc xs - -- 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 l - | null l = [InvalidWildcard] -- '*' is always invalid - | l == drop 1 (splitDot fqhn) = [] -- success: we got a match - | otherwise = [NameMismatch fqhn] + matchDomain :: String -> [FailedReason] + matchDomain name = case splitDot name of + l + | any (== "") l -> [InvalidName name] + | head l == "*" -> wildcardMatch (drop 1 l) + | l == splitDot fqhn -> [] -- success: we got a match + | otherwise -> [NameMismatch fqhn] - splitDot :: String -> [String] - splitDot [] = [""] - splitDot x = - let (y, z) = break (== '.') x in - map toLower y : (if z == "" then [] else splitDot $ drop 1 z) + -- 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 l + | null l = [InvalidWildcard] -- '*' is always invalid + | l == drop 1 (splitDot fqhn) = [] -- success: we got a match + | otherwise = [NameMismatch fqhn] + splitDot :: String -> [String] + splitDot [] = [""] + splitDot x = + let (y, z) = break (== '.') x + in map toLower y : (if z == "" then [] else splitDot $ drop 1 z) -- | return true if the 'subject' certificate's issuer match -- the 'issuer' certificate's subject @@ -395,12 +465,12 @@ exhaustive :: Bool -> [FailedReason] -> [FailedReason] -> [FailedReason] exhaustive isExhaustive l1 l2 - | null l1 = l2 - | isExhaustive = l1 ++ l2 - | otherwise = l1 + | null l1 = l2 + | isExhaustive = l1 ++ l2 + | otherwise = l1 exhaustiveList :: Bool -> [(Bool, [FailedReason])] -> [FailedReason] -exhaustiveList _ [] = [] -exhaustiveList isExhaustive ((performCheck,c):cs) +exhaustiveList _ [] = [] +exhaustiveList isExhaustive ((performCheck, c) : cs) | performCheck = exhaustive isExhaustive c (exhaustiveList isExhaustive cs) - | otherwise = exhaustiveList isExhaustive cs + | otherwise = exhaustiveList isExhaustive cs diff --git a/Data/X509/Validation/Cache.hs b/Data/X509/Validation/Cache.hs --- a/Data/X509/Validation/Cache.hs +++ b/Data/X509/Validation/Cache.hs @@ -9,51 +9,69 @@ -- -- Define all the types necessary for the validation cache, -- and some simples instances of cache mechanism -module Data.X509.Validation.Cache - ( +module Data.X509.Validation.Cache ( -- * Cache for validation - ValidationCacheResult(..) - , ValidationCacheQueryCallback - , ValidationCacheAddCallback - , ValidationCache(..) + ValidationCacheResult (..), + ValidationCacheQueryCallback, + ValidationCacheAddCallback, + ValidationCache (..), + defaultValidationCache, + -- * Simple instances of cache mechanism - , exceptionValidationCache - , tofuValidationCache - ) where + exceptionValidationCache, + tofuValidationCache, +) where import Control.Concurrent -import Data.Default.Class +import Data.Default import Data.X509 -import Data.X509.Validation.Types import Data.X509.Validation.Fingerprint +import Data.X509.Validation.Types -- | The result of a cache query -data ValidationCacheResult = - ValidationCachePass -- ^ cache allow this fingerprint to go through - | ValidationCacheDenied String -- ^ cache denied this fingerprint for further validation - | ValidationCacheUnknown -- ^ unknown fingerprint in cache - deriving (Show,Eq) +data ValidationCacheResult + = -- | cache allow this fingerprint to go through + ValidationCachePass + | -- | cache denied this fingerprint for further validation + ValidationCacheDenied String + | -- | unknown fingerprint in cache + ValidationCacheUnknown + deriving (Show, Eq) -- | Validation cache query callback type -type ValidationCacheQueryCallback = ServiceID -- ^ connection's identification - -> Fingerprint -- ^ fingerprint of the leaf certificate - -> Certificate -- ^ leaf certificate - -> IO ValidationCacheResult -- ^ return if the operation is succesful or not +type ValidationCacheQueryCallback = + ServiceID + -- ^ connection's identification + -> Fingerprint + -- ^ fingerprint of the leaf certificate + -> Certificate + -- ^ leaf certificate + -> IO ValidationCacheResult + -- ^ return if the operation is succesful or not -- | Validation cache callback type -type ValidationCacheAddCallback = ServiceID -- ^ connection's identification - -> Fingerprint -- ^ fingerprint of the leaf certificate - -> Certificate -- ^ leaf certificate - -> IO () +type ValidationCacheAddCallback = + ServiceID + -- ^ connection's identification + -> Fingerprint + -- ^ fingerprint of the leaf certificate + -> Certificate + -- ^ leaf certificate + -> IO () -- | All the callbacks needed for querying and adding to the cache. data ValidationCache = ValidationCache - { cacheQuery :: ValidationCacheQueryCallback -- ^ cache querying callback - , cacheAdd :: ValidationCacheAddCallback -- ^ cache adding callback + { cacheQuery :: ValidationCacheQueryCallback + -- ^ cache querying callback + , cacheAdd :: ValidationCacheAddCallback + -- ^ cache adding callback } +defaultValidationCache :: ValidationCache +defaultValidationCache = exceptionValidationCache [] + instance Default ValidationCache where - def = exceptionValidationCache [] + def = defaultValidationCache -- | create a simple constant cache that list exceptions to the certification -- validation. Typically this is use to allow self-signed certificates for @@ -70,8 +88,9 @@ -- another cache mechanism need to be use. exceptionValidationCache :: [(ServiceID, Fingerprint)] -> ValidationCache exceptionValidationCache fingerprints = - ValidationCache (queryListCallback fingerprints) - (\_ _ _ -> return ()) + ValidationCache + (queryListCallback fingerprints) + (\_ _ _ -> return ()) -- | Trust on first use (TOFU) cache with an optional list of exceptions -- @@ -79,20 +98,27 @@ -- each succesfull validation it does add the fingerprint -- to the database. This prevent any further modification of the -- fingerprint for the remaining -tofuValidationCache :: [(ServiceID, Fingerprint)] -- ^ a list of exceptions - -> IO ValidationCache +tofuValidationCache + :: [(ServiceID, Fingerprint)] + -- ^ a list of exceptions + -> IO ValidationCache tofuValidationCache fingerprints = do l <- newMVar fingerprints - return $ ValidationCache (\s f c -> readMVar l >>= \list -> (queryListCallback list) s f c) - (\s f _ -> modifyMVar_ l (\list -> return ((s,f) : list))) + return $ + ValidationCache + (\s f c -> readMVar l >>= \list -> (queryListCallback list) s f c) + (\s f _ -> modifyMVar_ l (\list -> return ((s, f) : list))) -- | a cache query function working on list. -- don't use when the list grows a lot. queryListCallback :: [(ServiceID, Fingerprint)] -> ValidationCacheQueryCallback queryListCallback list = query - where query serviceID fingerprint _ = return $ - case lookup serviceID list of - Nothing -> ValidationCacheUnknown - Just f | fingerprint == f -> ValidationCachePass - | otherwise -> ValidationCacheDenied (show serviceID ++ " expected " ++ show f ++ " but got: " ++ show fingerprint) - + where + query serviceID fingerprint _ = return $ + case lookup serviceID list of + Nothing -> ValidationCacheUnknown + Just f + | fingerprint == f -> ValidationCachePass + | otherwise -> + ValidationCacheDenied + (show serviceID ++ " expected " ++ show f ++ " but got: " ++ show fingerprint) diff --git a/Data/X509/Validation/Fingerprint.hs b/Data/X509/Validation/Fingerprint.hs --- a/Data/X509/Validation/Fingerprint.hs +++ b/Data/X509/Validation/Fingerprint.hs @@ -1,37 +1,41 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | -- Module : Data.X509.Validation.Fingerprint -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown --- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Data.X509.Validation.Fingerprint - ( Fingerprint(..) - , getFingerprint - ) where +module Data.X509.Validation.Fingerprint ( + Fingerprint (..), + getFingerprint, +) where import Crypto.Hash -import Data.X509 import Data.ASN1.Types -import Data.ByteArray (convert, ByteArrayAccess) +import Data.ByteArray (ByteArrayAccess, convert) import Data.ByteString (ByteString) +import Data.X509 -- | Fingerprint of a certificate newtype Fingerprint = Fingerprint ByteString - deriving (Show,Eq,ByteArrayAccess) + deriving (Show, Eq, ByteArrayAccess) -- | Get the fingerprint of the whole signed object -- using the hashing algorithm specified -getFingerprint :: (Show a, Eq a, ASN1Object a) - => SignedExact a -- ^ object to fingerprint - -> HashALG -- ^ algorithm to compute the fingerprint - -> Fingerprint -- ^ fingerprint in binary form +getFingerprint + :: (Show a, Eq a, ASN1Object a) + => SignedExact a + -- ^ object to fingerprint + -> HashALG + -- ^ algorithm to compute the fingerprint + -> Fingerprint + -- ^ fingerprint in binary form getFingerprint sobj halg = Fingerprint $ mkHash halg $ encodeSignedObject sobj where - mkHash HashMD2 = convert . hashWith MD2 - mkHash HashMD5 = convert . hashWith MD5 - mkHash HashSHA1 = convert . hashWith SHA1 + mkHash HashMD2 = convert . hashWith MD2 + mkHash HashMD5 = convert . hashWith MD5 + mkHash HashSHA1 = convert . hashWith SHA1 mkHash HashSHA224 = convert . hashWith SHA224 mkHash HashSHA256 = convert . hashWith SHA256 mkHash HashSHA384 = convert . hashWith SHA384 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 @@ -6,30 +6,29 @@ -- Portability : unknown -- -- X.509 Certificate and CRL signature verification --- -module Data.X509.Validation.Signature - ( verifySignedSignature - , verifySignature - , SignatureVerification(..) - , SignatureFailure(..) - ) where +module Data.X509.Validation.Signature ( + verifySignedSignature, + verifySignature, + SignatureVerification (..), + SignatureFailure (..), +) where -import Crypto.Error (CryptoFailable(..)) -import qualified Crypto.PubKey.RSA.PKCS15 as RSA -import qualified Crypto.PubKey.RSA.PSS as PSS +import Crypto.Error (CryptoFailable (..)) +import Crypto.Hash import qualified Crypto.PubKey.DSA as DSA -import qualified Crypto.PubKey.ECC.Types as ECC import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Types as ECC import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 -import Crypto.Hash +import qualified Crypto.PubKey.RSA.PKCS15 as RSA +import qualified Crypto.PubKey.RSA.PSS as PSS +import Data.ASN1.BinaryEncoding +import Data.ASN1.Encoding +import Data.ASN1.Types import Data.ByteString (ByteString) import Data.X509 import Data.X509.EC -import Data.ASN1.Types -import Data.ASN1.Encoding -import Data.ASN1.BinaryEncoding -- | A set of possible return from signature verification. -- @@ -38,126 +37,140 @@ -- -- Other values are only useful to differentiate the failure -- reason, but are all equivalent to failure. --- -data SignatureVerification = - SignaturePass -- ^ verification succeeded - | SignatureFailed SignatureFailure -- ^ verification failed - deriving (Show,Eq) +data SignatureVerification + = -- | verification succeeded + SignaturePass + | -- | verification failed + SignatureFailed SignatureFailure + 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) +data SignatureFailure + = -- | signature doesn't verify + SignatureInvalid + | -- | algorithm and public key mismatch, cannot proceed + SignaturePubkeyMismatch + | -- | unimplemented signature algorithm + SignatureUnimplemented + deriving (Show, Eq) -- | Verify a Signed object against a specified public key -verifySignedSignature :: (Show a, Eq a, ASN1Object a) - => SignedExact a - -> PubKey - -> SignatureVerification +verifySignedSignature + :: (Show a, Eq a, ASN1Object a) + => SignedExact a + -> PubKey + -> SignatureVerification verifySignedSignature signedObj pubKey = - verifySignature (signedAlg signed) - pubKey - (getSignedData signedObj) - (signedSignature signed) - where signed = getSigned signedObj + verifySignature + (signedAlg signed) + pubKey + (getSignedData signedObj) + (signedSignature signed) + where + signed = getSigned signedObj -- | verify signature using parameter -verifySignature :: SignatureALG -- ^ Signature algorithm used - -> PubKey -- ^ Public key to use for verify - -> ByteString -- ^ Certificate data that need to be verified - -> ByteString -- ^ Signature to verify - -> SignatureVerification +verifySignature + :: SignatureALG + -- ^ Signature algorithm used + -> PubKey + -- ^ Public key to use for verify + -> ByteString + -- ^ Certificate data that need to be verified + -> ByteString + -- ^ Signature to verify + -> SignatureVerification verifySignature (SignatureALG_Unknown _) _ _ _ = SignatureFailed SignatureUnimplemented verifySignature (SignatureALG hashALG PubKeyALG_RSAPSS) pubkey cdata signature = case verifyF pubkey of - Nothing -> SignatureFailed SignatureUnimplemented - Just f -> if f cdata signature - then SignaturePass - else SignatureFailed SignatureInvalid + Nothing -> SignatureFailed SignatureUnimplemented + Just f -> + if f cdata signature + then SignaturePass + else SignatureFailed SignatureInvalid where verifyF (PubKeyRSA key) - | hashALG == HashSHA256 = Just $ PSS.verify (PSS.defaultPSSParams SHA256) key - | hashALG == HashSHA384 = Just $ PSS.verify (PSS.defaultPSSParams SHA384) key - | hashALG == HashSHA512 = Just $ PSS.verify (PSS.defaultPSSParams SHA512) key - | hashALG == HashSHA224 = Just $ PSS.verify (PSS.defaultPSSParams SHA224) key - | otherwise = Nothing - verifyF _ = Nothing + | hashALG == HashSHA256 = Just $ PSS.verify (PSS.defaultPSSParams SHA256) key + | hashALG == HashSHA384 = Just $ PSS.verify (PSS.defaultPSSParams SHA384) key + | hashALG == HashSHA512 = Just $ PSS.verify (PSS.defaultPSSParams SHA512) key + | hashALG == HashSHA224 = Just $ PSS.verify (PSS.defaultPSSParams SHA224) key + | otherwise = Nothing + verifyF _ = Nothing verifySignature (SignatureALG hashALG pubkeyALG) pubkey cdata signature | pubkeyToAlg pubkey == pubkeyALG = case verifyF pubkey of - Nothing -> SignatureFailed SignatureUnimplemented - Just f -> if f cdata signature - then SignaturePass - else SignatureFailed SignatureInvalid - | otherwise = SignatureFailed SignaturePubkeyMismatch + Nothing -> SignatureFailed SignatureUnimplemented + Just f -> + if f cdata signature + then SignaturePass + else SignatureFailed SignatureInvalid + | otherwise = SignatureFailed SignaturePubkeyMismatch where - verifyF (PubKeyRSA key) = Just $ rsaVerify hashALG key - verifyF (PubKeyDSA key) - | hashALG == HashSHA1 = Just $ dsaVerify SHA1 key - | hashALG == HashSHA224 = Just $ dsaVerify SHA224 key - | hashALG == HashSHA256 = Just $ dsaVerify SHA256 key - | otherwise = Nothing - verifyF (PubKeyEC key) = verifyECDSA hashALG key - verifyF _ = Nothing - - dsaToSignature :: ByteString -> Maybe DSA.Signature - dsaToSignature b = - case decodeASN1' BER b of - Left _ -> Nothing - Right asn1 -> - case asn1 of - Start Sequence:IntVal r:IntVal s:End Sequence:_ -> - Just $ DSA.Signature { DSA.sign_r = r, DSA.sign_s = s } - _ -> - Nothing + verifyF (PubKeyRSA key) = Just $ rsaVerify hashALG key + verifyF (PubKeyDSA key) + | hashALG == HashSHA1 = Just $ dsaVerify SHA1 key + | hashALG == HashSHA224 = Just $ dsaVerify SHA224 key + | hashALG == HashSHA256 = Just $ dsaVerify SHA256 key + | otherwise = Nothing + verifyF (PubKeyEC key) = verifyECDSA hashALG key + verifyF _ = Nothing - dsaVerify hsh key b a = - case dsaToSignature a of - Nothing -> False - Just dsaSig -> DSA.verify hsh key dsaSig b + dsaToSignature :: ByteString -> Maybe DSA.Signature + dsaToSignature b = + case decodeASN1' BER b of + Left _ -> Nothing + Right asn1 -> + case asn1 of + Start Sequence : IntVal r : IntVal s : End Sequence : _ -> + Just $ DSA.Signature{DSA.sign_r = r, DSA.sign_s = s} + _ -> + Nothing - rsaVerify HashMD2 = RSA.verify (Just MD2) - rsaVerify HashMD5 = RSA.verify (Just MD5) - rsaVerify HashSHA1 = RSA.verify (Just SHA1) - rsaVerify HashSHA224 = RSA.verify (Just SHA224) - rsaVerify HashSHA256 = RSA.verify (Just SHA256) - rsaVerify HashSHA384 = RSA.verify (Just SHA384) - rsaVerify HashSHA512 = RSA.verify (Just SHA512) + dsaVerify hsh key b a = + case dsaToSignature a of + Nothing -> False + Just dsaSig -> DSA.verify hsh key dsaSig b + rsaVerify HashMD2 = RSA.verify (Just MD2) + rsaVerify HashMD5 = RSA.verify (Just MD5) + rsaVerify HashSHA1 = RSA.verify (Just SHA1) + rsaVerify HashSHA224 = RSA.verify (Just SHA224) + rsaVerify HashSHA256 = RSA.verify (Just SHA256) + rsaVerify HashSHA384 = RSA.verify (Just SHA384) + rsaVerify HashSHA512 = RSA.verify (Just SHA512) verifySignature (SignatureALG_IntrinsicHash pubkeyALG) pubkey cdata signature | pubkeyToAlg pubkey == pubkeyALG = doVerify pubkey | otherwise = SignatureFailed SignaturePubkeyMismatch where doVerify (PubKeyEd25519 key) = eddsa Ed25519.verify Ed25519.signature key - doVerify (PubKeyEd448 key) = eddsa Ed448.verify Ed448.signature key - doVerify _ = SignatureFailed SignatureUnimplemented + doVerify (PubKeyEd448 key) = eddsa Ed448.verify Ed448.signature key + doVerify _ = SignatureFailed SignatureUnimplemented eddsa verify toSig key = case toSig signature of CryptoPassed sig | verify key cdata sig -> SignaturePass - | otherwise -> SignatureFailed SignatureInvalid - CryptoFailed _ -> SignatureFailed SignatureInvalid + | otherwise -> SignatureFailed SignatureInvalid + CryptoFailed _ -> SignatureFailed SignatureInvalid verifyECDSA :: HashALG -> PubKeyEC -> Maybe (ByteString -> ByteString -> Bool) verifyECDSA hashALG key = ecPubKeyCurveName key >>= verifyCurve (pubkeyEC_pub key) where - verifyCurve pub curveName = Just $ \msg sigBS -> - case decodeASN1' BER sigBS of - Left _ -> False - Right [Start Sequence,IntVal r,IntVal s,End Sequence] -> - let curve = ECC.getCurveByName curveName - in case unserializePoint curve pub of - Nothing -> False - Just p -> let pubkey = ECDSA.PublicKey curve p - in (ecdsaVerify hashALG) pubkey (ECDSA.Signature r s) msg - Right _ -> False + verifyCurve pub curveName = Just $ \msg sigBS -> + case decodeASN1' BER sigBS of + Left _ -> False + Right [Start Sequence, IntVal r, IntVal s, End Sequence] -> + let curve = ECC.getCurveByName curveName + in case unserializePoint curve pub of + Nothing -> False + Just p -> + let pubkey = ECDSA.PublicKey curve p + in (ecdsaVerify hashALG) pubkey (ECDSA.Signature r s) msg + Right _ -> False - ecdsaVerify HashMD2 = ECDSA.verify MD2 - ecdsaVerify HashMD5 = ECDSA.verify MD5 - ecdsaVerify HashSHA1 = ECDSA.verify SHA1 - ecdsaVerify HashSHA224 = ECDSA.verify SHA224 - ecdsaVerify HashSHA256 = ECDSA.verify SHA256 - ecdsaVerify HashSHA384 = ECDSA.verify SHA384 - ecdsaVerify HashSHA512 = ECDSA.verify SHA512 + ecdsaVerify HashMD2 = ECDSA.verify MD2 + ecdsaVerify HashMD5 = ECDSA.verify MD5 + ecdsaVerify HashSHA1 = ECDSA.verify SHA1 + ecdsaVerify HashSHA224 = ECDSA.verify SHA224 + ecdsaVerify HashSHA256 = ECDSA.verify SHA256 + ecdsaVerify HashSHA384 = ECDSA.verify SHA384 + ecdsaVerify HashSHA512 = ECDSA.verify SHA512 diff --git a/Data/X509/Validation/Types.hs b/Data/X509/Validation/Types.hs --- a/Data/X509/Validation/Types.hs +++ b/Data/X509/Validation/Types.hs @@ -6,10 +6,10 @@ -- Portability : unknown -- -- X.509 Validation types -module Data.X509.Validation.Types - ( ServiceID - , HostName - ) where +module Data.X509.Validation.Types ( + ServiceID, + HostName, +) where import Data.ByteString (ByteString) @@ -25,5 +25,4 @@ -- certificate on 2 differents ports (443 and 995) for the same host. -- -- for TCP connection, it's recommended to use: :port, or :service for the suffix. --- type ServiceID = (HostName, ByteString) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/Tests/Certificate.hs b/Tests/Certificate.hs --- a/Tests/Certificate.hs +++ b/Tests/Certificate.hs @@ -1,49 +1,52 @@ {-# LANGUAGE GADTs #-} + -- | Types and functions used to build test certificates. -module Certificate - ( +module Certificate ( -- * Hash algorithms - hashMD2 - , hashMD5 - , hashSHA1 - , hashSHA224 - , hashSHA256 - , hashSHA384 - , hashSHA512 + hashMD2, + hashMD5, + hashSHA1, + hashSHA224, + hashSHA256, + hashSHA384, + hashSHA512, + -- * Key and signature utilities - , Alg(..) - , Keys - , generateKeys + Alg (..), + Keys, + generateKeys, + -- * Certificate utilities - , Pair(..) - , mkDn - , mkExtension - , leafStdExts + Pair (..), + mkDn, + mkExtension, + leafStdExts, + -- * Certificate creation functions - , Auth(..) - , mkCertificate - , mkCA - , mkLeaf - ) where + Auth (..), + mkCertificate, + mkCA, + mkLeaf, +) where import Control.Applicative import Crypto.Hash.Algorithms import Crypto.Number.Serialize -import qualified Crypto.PubKey.DSA as DSA -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Generate as ECC -import qualified Crypto.PubKey.ECC.Types as ECC -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import qualified Crypto.PubKey.Ed448 as Ed448 -import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.ECC.Types as ECC +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA -import qualified Crypto.PubKey.RSA.PSS as PSS +import qualified Crypto.PubKey.RSA.PSS as PSS import qualified Data.ByteString as B -import Data.ASN1.BinaryEncoding (DER(..)) +import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding import Data.ASN1.Types import Data.ByteArray (convert) @@ -53,25 +56,23 @@ import Data.Hourglass - -- Crypto utilities -- -- | Hash algorithms supported in certificates. -- -- This relates the typed hash algorithm @hash@ to the 'HashALG' value. -data GHash hash = GHash { getHashALG :: HashALG, getHashAlgorithm :: hash } +data GHash hash = GHash {getHashALG :: HashALG, getHashAlgorithm :: hash} -hashMD2 :: GHash MD2 -hashMD5 :: GHash MD5 -hashSHA1 :: GHash SHA1 +hashMD2 :: GHash MD2 +hashMD5 :: GHash MD5 +hashSHA1 :: GHash SHA1 hashSHA224 :: GHash SHA224 hashSHA256 :: GHash SHA256 hashSHA384 :: GHash SHA384 hashSHA512 :: GHash SHA512 - -hashMD2 = GHash HashMD2 MD2 -hashMD5 = GHash HashMD5 MD5 -hashSHA1 = GHash HashSHA1 SHA1 +hashMD2 = GHash HashMD2 MD2 +hashMD5 = GHash HashMD5 MD5 +hashSHA1 = GHash HashSHA1 SHA1 hashSHA224 = GHash HashSHA224 SHA224 hashSHA256 = GHash HashSHA256 SHA256 hashSHA384 = GHash HashSHA384 SHA384 @@ -79,117 +80,120 @@ -- | Signature and hash algorithms instantiated with parameters. data Alg pub priv where - AlgRSA :: (HashAlgorithm hash, RSA.HashAlgorithmASN1 hash) - => Int - -> GHash hash - -> Alg RSA.PublicKey RSA.PrivateKey - - AlgRSAPSS :: HashAlgorithm hash - => Int - -> PSS.PSSParams hash B.ByteString B.ByteString - -> GHash hash - -> Alg RSA.PublicKey RSA.PrivateKey - - AlgDSA :: HashAlgorithm hash - => DSA.Params - -> GHash hash - -> Alg DSA.PublicKey DSA.PrivateKey - - AlgEC :: HashAlgorithm hash - => ECC.CurveName - -> GHash hash - -> Alg ECDSA.PublicKey ECDSA.PrivateKey - + AlgRSA + :: (HashAlgorithm hash, RSA.HashAlgorithmASN1 hash) + => Int + -> GHash hash + -> Alg RSA.PublicKey RSA.PrivateKey + AlgRSAPSS + :: HashAlgorithm hash + => Int + -> PSS.PSSParams hash B.ByteString B.ByteString + -> GHash hash + -> Alg RSA.PublicKey RSA.PrivateKey + AlgDSA + :: HashAlgorithm hash + => DSA.Params + -> GHash hash + -> Alg DSA.PublicKey DSA.PrivateKey + AlgEC + :: HashAlgorithm hash + => ECC.CurveName + -> GHash hash + -> Alg ECDSA.PublicKey ECDSA.PrivateKey AlgEd25519 :: Alg Ed25519.PublicKey Ed25519.SecretKey - - AlgEd448 :: Alg Ed448.PublicKey Ed448.SecretKey + AlgEd448 :: Alg Ed448.PublicKey Ed448.SecretKey -- | Types of public and private keys used by a signature algorithm. type Keys pub priv = (Alg pub priv, pub, priv) -- | Generates random keys for a signature algorithm. generateKeys :: Alg pub priv -> IO (Keys pub priv) -generateKeys alg@(AlgRSA bits _) = generateRSAKeys alg bits +generateKeys alg@(AlgRSA bits _) = generateRSAKeys alg bits generateKeys alg@(AlgRSAPSS bits _ _) = generateRSAKeys alg bits -generateKeys alg@(AlgDSA params _) = do +generateKeys alg@(AlgDSA params _) = do x <- DSA.generatePrivate params let y = DSA.calculatePublic params x return (alg, DSA.PublicKey params y, DSA.PrivateKey params x) -generateKeys alg@(AlgEC name _) = do +generateKeys alg@(AlgEC name _) = do let curve = ECC.getCurveByName name (pub, priv) <- ECC.generate curve return (alg, pub, priv) -generateKeys alg@AlgEd25519 = do +generateKeys alg@AlgEd25519 = do secret <- Ed25519.generateSecretKey return (alg, Ed25519.toPublic secret, secret) -generateKeys alg@AlgEd448 = do +generateKeys alg@AlgEd448 = do secret <- Ed448.generateSecretKey return (alg, Ed448.toPublic secret, secret) -generateRSAKeys :: Alg RSA.PublicKey RSA.PrivateKey - -> Int - -> IO (Alg RSA.PublicKey RSA.PrivateKey, RSA.PublicKey, RSA.PrivateKey) +generateRSAKeys + :: Alg RSA.PublicKey RSA.PrivateKey + -> Int + -> IO (Alg RSA.PublicKey RSA.PrivateKey, RSA.PublicKey, RSA.PrivateKey) generateRSAKeys alg bits = addAlg <$> RSA.generate size e where addAlg (pub, priv) = (alg, pub, priv) size = bits `div` 8 - e = 3 + e = 3 getPubKey :: Alg pub priv -> pub -> PubKey -getPubKey (AlgRSA _ _) key = PubKeyRSA key -getPubKey (AlgRSAPSS _ _ _) key = PubKeyRSA key -getPubKey (AlgDSA _ _) key = PubKeyDSA key -getPubKey (AlgEC name _) key = PubKeyEC (PubKeyEC_Named name pub) +getPubKey (AlgRSA _ _) key = PubKeyRSA key +getPubKey (AlgRSAPSS _ _ _) key = PubKeyRSA key +getPubKey (AlgDSA _ _) key = PubKeyDSA key +getPubKey (AlgEC name _) key = PubKeyEC (PubKeyEC_Named name pub) where ECC.Point x y = ECDSA.public_q key - pub = SerializedPoint bs - bs = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y) - bits = ECC.curveSizeBits (ECC.getCurveByName name) + pub = SerializedPoint bs + bs = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y) + bits = ECC.curveSizeBits (ECC.getCurveByName name) bytes = (bits + 7) `div` 8 -getPubKey AlgEd25519 key = PubKeyEd25519 key -getPubKey AlgEd448 key = PubKeyEd448 key +getPubKey AlgEd25519 key = PubKeyEd25519 key +getPubKey AlgEd448 key = PubKeyEd448 key getSignatureALG :: Alg pub priv -> SignatureALG -getSignatureALG (AlgRSA _ hash) = SignatureALG (getHashALG hash) PubKeyALG_RSA +getSignatureALG (AlgRSA _ hash) = SignatureALG (getHashALG hash) PubKeyALG_RSA getSignatureALG (AlgRSAPSS _ _ hash) = SignatureALG (getHashALG hash) PubKeyALG_RSAPSS -getSignatureALG (AlgDSA _ hash) = SignatureALG (getHashALG hash) PubKeyALG_DSA -getSignatureALG (AlgEC _ hash) = SignatureALG (getHashALG hash) PubKeyALG_EC -getSignatureALG AlgEd25519 = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -getSignatureALG AlgEd448 = SignatureALG_IntrinsicHash PubKeyALG_Ed448 +getSignatureALG (AlgDSA _ hash) = SignatureALG (getHashALG hash) PubKeyALG_DSA +getSignatureALG (AlgEC _ hash) = SignatureALG (getHashALG hash) PubKeyALG_EC +getSignatureALG AlgEd25519 = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 +getSignatureALG AlgEd448 = SignatureALG_IntrinsicHash PubKeyALG_Ed448 doSign :: Alg pub priv -> priv -> B.ByteString -> IO B.ByteString -doSign (AlgRSA _ hash) key msg = do +doSign (AlgRSA _ hash) key msg = do result <- RSA.signSafer (Just $ getHashAlgorithm hash) key msg case result of - Left err -> error ("doSign(AlgRSA): " ++ show err) + Left err -> error ("doSign(AlgRSA): " ++ show err) Right sigBits -> return sigBits doSign (AlgRSAPSS _ params _) key msg = do result <- PSS.signSafer params key msg case result of - Left err -> error ("doSign(AlgRSAPSS): " ++ show err) + Left err -> error ("doSign(AlgRSAPSS): " ++ show err) Right sigBits -> return sigBits -doSign (AlgDSA _ hash) key msg = do +doSign (AlgDSA _ hash) key msg = do sig <- DSA.sign key (getHashAlgorithm hash) msg - return $ encodeASN1' DER - [ Start Sequence - , IntVal (DSA.sign_r sig) - , IntVal (DSA.sign_s sig) - , End Sequence - ] -doSign (AlgEC _ hash) key msg = do + return $ + encodeASN1' + DER + [ Start Sequence + , IntVal (DSA.sign_r sig) + , IntVal (DSA.sign_s sig) + , End Sequence + ] +doSign (AlgEC _ hash) key msg = do sig <- ECDSA.sign key (getHashAlgorithm hash) msg - return $ encodeASN1' DER - [ Start Sequence - , IntVal (ECDSA.sign_r sig) - , IntVal (ECDSA.sign_s sig) - , End Sequence - ] -doSign AlgEd25519 key msg = + return $ + encodeASN1' + DER + [ Start Sequence + , IntVal (ECDSA.sign_r sig) + , IntVal (ECDSA.sign_s sig) + , End Sequence + ] +doSign AlgEd25519 key msg = return $ convert $ Ed25519.sign key (Ed25519.toPublic key) msg -doSign AlgEd448 key msg = +doSign AlgEd448 key msg = return $ convert $ Ed448.sign key (Ed448.toPublic key) msg - -- Certificate utilities -- -- | Holds together a certificate and its private key for convenience. @@ -197,9 +201,9 @@ -- Contains also the crypto algorithm that both are issued from. This is -- useful when signing another certificate. data Pair pub priv = Pair - { pairAlg :: Alg pub priv + { pairAlg :: Alg pub priv , pairSignedCert :: SignedCertificate - , pairKey :: priv + , pairKey :: priv } -- | Builds a DN with a single component. @@ -214,11 +218,14 @@ leafStdExts :: [ExtensionRaw] leafStdExts = [ku, eku] where - ku = mkExtension False $ ExtKeyUsage - [ KeyUsage_digitalSignature , KeyUsage_keyEncipherment ] - eku = mkExtension False $ ExtExtendedKeyUsage - [ KeyUsagePurpose_ServerAuth , KeyUsagePurpose_ClientAuth ] - + ku = + mkExtension False $ + ExtKeyUsage + [KeyUsage_digitalSignature, KeyUsage_keyEncipherment] + eku = + mkExtension False $ + ExtExtendedKeyUsage + [KeyUsagePurpose_ServerAuth, KeyUsagePurpose_ClientAuth] -- Authority signing a certificate -- -- @@ -229,68 +236,81 @@ -- | Authority signing a certificate, itself or another certificate. data Auth pubI privI pubS privS where Self :: (pubI ~ pubS, privI ~ privS) => Auth pubI privI pubS privS - CA :: Pair pubI privI -> Auth pubI privI pubS privS + CA :: Pair pubI privI -> Auth pubI privI pubS privS -foldAuth :: a - -> (Pair pubI privI -> a) - -> Auth pubI privI pubS privS - -> a -foldAuth x _ Self = x -- no constraint used +foldAuth + :: a + -> (Pair pubI privI -> a) + -> Auth pubI privI pubS privS + -> a +foldAuth x _ Self = x -- no constraint used foldAuth _ f (CA p) = f p -foldAuthPriv :: privS - -> (Pair pubI privI -> privI) - -> Auth pubI privI pubS privS - -> privI -foldAuthPriv x _ Self = x -- uses constraint privI ~ privS +foldAuthPriv + :: privS + -> (Pair pubI privI -> privI) + -> Auth pubI privI pubS privS + -> privI +foldAuthPriv x _ Self = x -- uses constraint privI ~ privS foldAuthPriv _ f (CA p) = f p -foldAuthPubPriv :: k pubS privS - -> (Pair pubI privI -> k pubI privI) - -> Auth pubI privI pubS privS - -> k pubI privI -foldAuthPubPriv x _ Self = x -- uses both constraints +foldAuthPubPriv + :: k pubS privS + -> (Pair pubI privI -> k pubI privI) + -> Auth pubI privI pubS privS + -> k pubI privI +foldAuthPubPriv x _ Self = x -- uses both constraints foldAuthPubPriv _ f (CA p) = f p - -- Certificate creation functions -- -- | Builds a certificate using the supplied keys and signs it with an -- authority (itself or another certificate). -mkCertificate :: Int -- ^ Certificate version - -> Integer -- ^ Serial number - -> DistinguishedName -- ^ Subject DN - -> (DateTime, DateTime) -- ^ Certificate validity period - -> [ExtensionRaw] -- ^ Extensions to include - -> Auth pubI privI pubS privS -- ^ Authority signing the new certificate - -> Keys pubS privS -- ^ Keys for the new certificate - -> IO (Pair pubS privS) -- ^ The new certificate/key pair +mkCertificate + :: Int + -- ^ Certificate version + -> Integer + -- ^ Serial number + -> DistinguishedName + -- ^ Subject DN + -> (DateTime, DateTime) + -- ^ Certificate validity period + -> [ExtensionRaw] + -- ^ Extensions to include + -> Auth pubI privI pubS privS + -- ^ Authority signing the new certificate + -> Keys pubS privS + -- ^ Keys for the new certificate + -> IO (Pair pubS privS) + -- ^ The new certificate/key pair mkCertificate version serial dn validity exts auth (algS, pubKey, privKey) = do signedCert <- objectToSignedExactF signatureFunction cert - return Pair { pairAlg = algS - , pairSignedCert = signedCert - , pairKey = privKey - } - + return + Pair + { pairAlg = algS + , pairSignedCert = signedCert + , pairKey = privKey + } where pairCert = signedObject . getSigned . pairSignedCert - cert = Certificate - { certVersion = version - , certSerial = serial - , certSignatureAlg = signAlgI - , certIssuerDN = issuerDN - , certValidity = validity - , certSubjectDN = dn - , certPubKey = getPubKey algS pubKey - , certExtensions = extensions - } + cert = + Certificate + { certVersion = version + , certSerial = serial + , certSignatureAlg = signAlgI + , certIssuerDN = issuerDN + , certValidity = validity + , certSubjectDN = dn + , certPubKey = getPubKey algS pubKey + , certExtensions = extensions + } - signingKey = foldAuthPriv privKey pairKey auth - algI = foldAuthPubPriv algS pairAlg auth + signingKey = foldAuthPriv privKey pairKey auth + algI = foldAuthPubPriv algS pairAlg auth - signAlgI = getSignatureALG algI - issuerDN = foldAuth dn (certSubjectDN . pairCert) auth + signAlgI = getSignatureALG algI + issuerDN = foldAuth dn (certSubjectDN . pairCert) auth extensions = Extensions (if null exts then Nothing else Just exts) signatureFunction objRaw = do @@ -299,23 +319,38 @@ -- | Builds a CA certificate using the supplied keys and signs it with an -- authority (itself or another certificate). -mkCA :: Integer -- ^ Serial number - -> String -- ^ Common name - -> (DateTime, DateTime) -- ^ CA validity period - -> Maybe ExtBasicConstraints -- ^ CA basic constraints - -> Maybe ExtKeyUsage -- ^ CA key usage - -> Auth pubI privI pubS privS -- ^ Authority signing the new certificate - -> Keys pubS privS -- ^ Keys for the new certificate - -> IO (Pair pubS privS) -- ^ The new CA certificate/key pair +mkCA + :: Integer + -- ^ Serial number + -> String + -- ^ Common name + -> (DateTime, DateTime) + -- ^ CA validity period + -> Maybe ExtBasicConstraints + -- ^ CA basic constraints + -> Maybe ExtKeyUsage + -- ^ CA key usage + -> Auth pubI privI pubS privS + -- ^ Authority signing the new certificate + -> Keys pubS privS + -- ^ Keys for the new certificate + -> IO (Pair pubS privS) + -- ^ The new CA certificate/key pair mkCA serial cn validity bc ku = - let exts = catMaybes [ mkExtension True <$> bc, mkExtension False <$> ku ] - in mkCertificate 2 serial (mkDn cn) validity exts + let exts = catMaybes [mkExtension True <$> bc, mkExtension False <$> ku] + in mkCertificate 2 serial (mkDn cn) validity exts -- | Builds a leaf certificate using the supplied keys and signs it with an -- authority (itself or another certificate). -mkLeaf :: String -- ^ Common name - -> (DateTime, DateTime) -- ^ Certificate validity period - -> Auth pubI privI pubS privS -- ^ Authority signing the new certificate - -> Keys pubS privS -- ^ Keys for the new certificate - -> IO (Pair pubS privS) -- ^ The new leaf certificate/key pair +mkLeaf + :: String + -- ^ Common name + -> (DateTime, DateTime) + -- ^ Certificate validity period + -> Auth pubI privI pubS privS + -- ^ Authority signing the new certificate + -> Keys pubS privS + -- ^ Keys for the new certificate + -> IO (Pair pubS privS) + -- ^ The new leaf certificate/key pair mkLeaf cn validity = mkCertificate 2 100 (mkDn cn) validity leafStdExts diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -6,592 +6,866 @@ import Crypto.Hash.Algorithms -import qualified Crypto.PubKey.DSA as DSA -import qualified Crypto.PubKey.ECC.Types as ECC -import qualified Crypto.PubKey.RSA.PSS as PSS - -import Data.Default.Class -import Data.Monoid -import Data.String (fromString) -import Data.X509 -import Data.X509.CertificateStore -import Data.X509.Validation - -import Data.Hourglass -import System.Hourglass - -import Test.Tasty -import Test.Tasty.HUnit - -import Certificate - - --- Runtime data, dynamically generated and shared by all test cases -- - -data RData pub priv = RData - { rootStore :: CertificateStore - , past :: (DateTime, DateTime) - , present :: (DateTime, DateTime) - , future :: (DateTime, DateTime) - , pastDate :: DateTime - , presentDate :: DateTime - , futureDate :: DateTime - , root :: Pair pub priv - , intermediate :: Pair pub priv - , intermediate0 :: Pair pub priv - , intermediatePast :: Pair pub priv - , intermediateFuture :: Pair pub priv - , keys1 :: Keys pub priv - , keys2 :: Keys pub priv - , keys3 :: Keys pub priv - } - -mkDateTime :: Date -> DateTime -mkDateTime d = DateTime d (TimeOfDay 0 0 0 0) - -mkStore :: [Pair pub priv] -> CertificateStore -mkStore ps = makeCertificateStore (map pairSignedCert ps) - -initData :: Alg pub priv -> IO (RData pub priv) -initData alg = do - today <- timeGetDate <$> timeCurrent - - let m3 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = -3 } - let m2 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = -2 } - let m1 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = -1 } - let n1 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = 1 } - let n2 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = 2 } - let n3 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = 3 } - - -- two-year validity periods in past, present and future - let vPast = (m3, m1) -- Year-3 .. Year-1 - let vPresent = (m1, n1) -- Year-1 .. Year+1 - let vFuture = (n1, n3) -- Year+1 .. Year+3 - - -- CA basic constraints and key usage extensions - let bc = Just $ ExtBasicConstraints True Nothing - let bc0 = Just $ ExtBasicConstraints True (Just 0) - let ku = Nothing - - -- Root CAs in past, present and future. Need distinct DNs because the - -- certificate store contains all 3 simultaneously. - rootPast <- generateKeys alg >>= mkCA 1 "RootCA - R1" vPast bc ku Self - rootPresent <- generateKeys alg >>= mkCA 2 "RootCA - R2" vPresent bc ku Self - rootFuture <- generateKeys alg >>= mkCA 3 "RootCA - R3" vFuture bc ku Self - - -- Intermediate CAs in past, present and future. Also includes a CA with - -- a depth constraint. - pIntermediateP <- generateKeys alg >>= mkCA 11 "IntermediateCA" vPast bc ku (CA rootPast) - pIntermediate <- generateKeys alg >>= mkCA 12 "IntermediateCA" vPresent bc ku (CA rootPresent) - pIntermediate0 <- generateKeys alg >>= mkCA 12 "IntermediateCA" vPresent bc0 ku (CA rootPresent) - pIntermediateF <- generateKeys alg >>= mkCA 13 "IntermediateCA" vFuture bc ku (CA rootFuture) - - -- Additional keys to be reused in test cases. This removes the cost of - -- generating individual keys. A key should be used only once per case. - k1 <- generateKeys alg - k2 <- generateKeys alg - k3 <- generateKeys alg - - return RData - { rootStore = mkStore [ rootPast, rootPresent, rootFuture ] - , past = vPast - , present = vPresent - , future = vFuture - , pastDate = m2 -- Year-2 - , presentDate = mkDateTime today - , futureDate = n2 -- Year+2 - , root = rootPresent - , intermediate = pIntermediate - , intermediate0 = pIntermediate0 - , intermediatePast = pIntermediateP - , intermediateFuture = pIntermediateF - , keys1 = k1 - , keys2 = k2 - , keys3 = k3 - } - -freeData :: RData pub priv -> IO () -freeData _ = return () - - --- Test utilities -- - --- | Asserts order-insensitive equality for lists. This also ignores --- duplicate elements. -assertEqualList :: (Eq a, Show a) => String -- ^ The message prefix - -> [a] -- ^ The expected value - -> [a] -- ^ The actual value - -> Assertion -assertEqualList preface expected actual = - unless (actual `same` expected) (assertFailure msg) - where - a `same` b = all (`elem` b) a && all (`elem` a) b - msg = (if null preface then "" else preface ++ "\n") ++ - " expected: " ++ show expected ++ "\n but got: " ++ show actual - --- | Asserts the validation result of a certificate chain. -assertValidationResult :: RData pub priv -- ^ Common test resources (CA store) - -> ValidationChecks -- ^ Checks to do - -> HostName -- ^ Connection identification - -> [Pair pub priv] -- ^ Certificate chain to validate - -> [FailedReason] -- ^ Expected validation result - -> Assertion -assertValidationResult rd checks hostname ps expected = do - actual <- validate HashSHA256 defaultHooks checks store def ident chain - assertEqualList "Unexpected validation result" expected actual - where - store = rootStore rd - ident = (hostname, fromString ":443") - chain = CertificateChain (map pairSignedCert ps) - --- | Simplified access to test resource from 'withResource'. -testWithRes :: IO r -> TestName -> (r -> Assertion) -> TestTree -testWithRes res caseName f = testCase caseName (res >>= f) - - --- Test cases -- - --- | Tests a leaf certificate signed by an intermediate CA, but using a chain --- where the intermediate CA may use a different key. This tests the signature --- of the leaf certificate provided both CAs have the same subject DN. -testSignature :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> (RData pub priv -> Pair pub priv) -- ^ CA to use for signature - -> (RData pub priv -> Pair pub priv) -- ^ CA to use for validation - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testSignature res caseName f g expected = testWithRes res caseName $ \rd -> do - pair <- mkLeaf "signature" (present rd) (CA $ f rd) (keys1 rd) - assertValidationResult rd defaultChecks "signature" [pair, g rd] expected - --- | Tests an empty certificate chain. -testEmpty :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testEmpty res caseName expected = testWithRes res caseName $ \rd -> - assertValidationResult rd defaultChecks "empty" [] expected - --- | Tests a certificate chain where the intermediate CA is missing. -testIncompleteChain :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testIncompleteChain res caseName expected = testWithRes res caseName $ \rd -> do - pair <- mkLeaf "incomplete" (present rd) (CA $ intermediate rd) (keys1 rd) - assertValidationResult rd defaultChecks "incomplete" [pair] expected - --- | Tests a self-signed certificate. -testSelfSigned :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testSelfSigned res caseName expected = testWithRes res caseName $ \rd -> do - pair <- mkLeaf "self-signed" (present rd) Self (keys1 rd) - assertValidationResult rd defaultChecks "self-signed" [pair] expected - --- | Tests key usage of intermediate CA, with or without 'checkCAConstraints'. -testCAKeyUsage :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> Bool -- ^ Value for 'checkCAConstraints' - -> ExtKeyUsageFlag -- ^ Intermediate CA key usage - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testCAKeyUsage res caseName check flag expected = testWithRes res caseName $ \rd -> do - ca <- mkCA 20 "KeyUsageCA" (present rd) bc ku (CA $ root rd) (keys1 rd) - pair <- mkLeaf "ca-key-usage" (present rd) (CA ca) (keys2 rd) - assertValidationResult rd checks "ca-key-usage" [pair, ca] expected - where - checks = defaultChecks { checkCAConstraints = check } - bc = Just (ExtBasicConstraints True Nothing) - ku = Just (ExtKeyUsage [flag]) - --- | Tests CA flag of intermediate CA, with or without 'checkCAConstraints'. -testNotCA :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> Bool -- ^ Value for 'checkCAConstraints' - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testNotCA res caseName check expected = testWithRes res caseName $ \rd -> do - ca <- mkCA 20 "NotCA" (present rd) bc Nothing (CA $ root rd) (keys1 rd) - pair <- mkLeaf "not-ca" (present rd) (CA ca) (keys2 rd) - assertValidationResult rd checks "not-ca" [pair, ca] expected - where - checks = defaultChecks { checkCAConstraints = check } - bc = Just (ExtBasicConstraints False Nothing) - --- | Tests an intermediate CA without basic constraints, with or without --- 'checkCAConstraints'. -testNoBasic :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> Bool -- ^ Value for 'checkCAConstraints' - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testNoBasic res caseName check expected = testWithRes res caseName $ \rd -> do - ca <- mkCA 20 "NoBC" (present rd) bc Nothing (CA $ root rd) (keys1 rd) - pair <- mkLeaf "no-bc" (present rd) (CA ca) (keys2 rd) - assertValidationResult rd checks "no-bc" [pair, ca] expected - where - checks = defaultChecks { checkCAConstraints = check } - bc = Nothing - --- | Tests basic constraints depth, with or without 'checkCAConstraints'. -testBadDepth :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> Bool -- ^ Value for 'checkCAConstraints' - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testBadDepth res caseName check expected = testWithRes res caseName $ \rd -> do - -- a new CA signed by intermediate0 should fail because of the depth limit - ca <- mkCA 20 "TooDeep" (present rd) bc Nothing (CA $ intermediate0 rd) (keys1 rd) - pair <- mkLeaf "bad-depth" (present rd) (CA ca) (keys2 rd) - assertValidationResult rd checks "bad-depth" [pair, ca, intermediate0 rd] expected - where - checks = defaultChecks { checkCAConstraints = check } - bc = Just (ExtBasicConstraints True Nothing) - --- | Tests a non-V3 leaf certificate, with or without 'checkLeafV3'. -testLeafNotV3 :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> Bool -- ^ Value for 'checkLeafV3' - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testLeafNotV3 res caseName check expected = testWithRes res caseName $ \rd -> do - pair <- mkCertificate 1 100 dn (present rd) leafStdExts (CA $ intermediate rd) (keys1 rd) - assertValidationResult rd checks "leaf-not-v3" [pair, intermediate rd] expected - where - checks = defaultChecks { checkLeafV3 = check } - dn = mkDn "leaf-not-v3" - --- | Tests a certificate chain containing a non-related certificate, with or --- without 'checkStrictOrdering'. -testStrictOrdering :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> Bool -- ^ Value for 'checkStrictOrdering' - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testStrictOrdering res caseName check expected = testWithRes res caseName $ \rd -> do - ca <- mkCA 20 "CA" (present rd) bc Nothing (CA $ intermediate rd) (keys1 rd) - extra <- mkCA 21 "Extra" (present rd) bc Nothing (CA $ intermediate rd) (keys2 rd) - pair <- mkLeaf "strict-ordering" (present rd) (CA ca) (keys3 rd) - assertValidationResult rd checks "strict-ordering" [pair, ca, extra, intermediate rd] expected - where - checks = defaultChecks { checkStrictOrdering = check } - bc = Just (ExtBasicConstraints True Nothing) - --- | Tests validity of leaf certificate. -testLeafDates :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> Bool -- ^ Value for 'checkTimeValidity' - -> (RData pub priv -> (DateTime, DateTime)) -- ^ Validity period to use - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testLeafDates res caseName check f expected = testWithRes res caseName $ \rd -> do - pair <- mkLeaf "leaf-dates" (f rd) (CA $ intermediate rd) (keys1 rd) - assertValidationResult rd checks "leaf-dates" [pair, intermediate rd] expected - where - checks = defaultChecks { checkTimeValidity = check } - --- | Tests validity of intermediate CA. -testIntermediateDates :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> Bool -- ^ Value for 'checkTimeValidity' - -> (RData pub priv -> Pair pub priv) -- ^ Intermediate CA to use - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testIntermediateDates res caseName check f expected = testWithRes res caseName $ \rd -> do - pair <- mkLeaf "intermediate-dates" (present rd) (CA $ f rd) (keys1 rd) - assertValidationResult rd checks "intermediate-dates" [pair, f rd] expected - where - checks = defaultChecks { checkTimeValidity = check } - --- | Tests validity of leaf certificate and intermediate CA, --- using 'checkAtTime'. -testTimeshift :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> (RData pub priv -> (DateTime, DateTime)) -- ^ Leaf validity period - -> (RData pub priv -> Pair pub priv) -- ^ Intermediate CA to use - -> (RData pub priv -> DateTime) -- ^ Value for 'checkAtTime' - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testTimeshift res caseName f g h expected = testWithRes res caseName $ \rd -> do - let checks = defaultChecks { checkAtTime = Just $ h rd } - pair <- mkLeaf "timeshift" (f rd) (CA $ g rd) (keys1 rd) - assertValidationResult rd checks "timeshift" [pair, g rd] expected - --- | Tests an empty DistinguishedName. -testNoCommonName :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testNoCommonName res caseName expected = testWithRes res caseName $ \rd -> do - pair <- mkCertificate 2 100 dn (present rd) leafStdExts (CA $ intermediate rd) (keys1 rd) - assertValidationResult rd defaultChecks "no-cn" [pair, intermediate rd] expected - where - dn = DistinguishedName [] - --- | Tests certificate CommonName against expected hostname, with or without --- 'checkFQHN'. -testCommonName :: IO (RData pub priv) -- ^ Common test resources - -> String -- ^ Certificate CommonName - -> HostName -- ^ Connection identification - -> Bool -- ^ Value for 'checkFQHN' - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testCommonName res cn hostname check expected = testWithRes res caseName $ \rd -> do - pair <- mkLeaf cn (present rd) (CA $ intermediate rd) (keys1 rd) - assertValidationResult rd checks hostname [pair, intermediate rd] expected - where - caseName = if null hostname then "empty" else hostname - checks = defaultChecks { checkFQHN = check } - --- | Tests certificate SubjectAltName against expected hostname, with or --- without 'checkFQHN'. -testSubjectAltName :: IO (RData pub priv) -- ^ Common test resources - -> String -- ^ Certificate SubjectAltName - -> HostName -- ^ Connection identification - -> Bool -- ^ Value for 'checkFQHN' - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testSubjectAltName res san hostname check expected = testWithRes res caseName $ \rd -> do - pair <- mkCertificate 2 100 dn (present rd) (ext:leafStdExts) (CA $ intermediate rd) (keys1 rd) - assertValidationResult rd checks hostname [pair, intermediate rd] expected - where - caseName = if null hostname then "empty" else hostname - checks = defaultChecks { checkFQHN = check } - dn = mkDn "cn-not-used" -- this CN value is to be tested too - -- (to make sure CN is *not* considered when a - -- SubjectAltName exists) - ext = mkExtension False $ - -- wraps test value with other values - ExtSubjectAltName [ AltNameDNS "dummy1" - , AltNameRFC822 "test@example.com" - , AltNameDNS san - , AltNameDNS "dummy2" - ] - --- | Tests 'checkLeafKeyUsage'. -testLeafKeyUsage :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> [ExtKeyUsageFlag] -- ^ Certificate flags - -> [ExtKeyUsageFlag] -- ^ Flags required for validation - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testLeafKeyUsage res caseName cFlags vFlags expected = testWithRes res caseName $ \rd -> do - pair <- mkCertificate 2 100 dn (present rd) exts (CA $ intermediate rd) (keys1 rd) - assertValidationResult rd checks "key-usage" [pair, intermediate rd] expected - where - checks = defaultChecks { checkLeafKeyUsage = vFlags } - dn = mkDn "key-usage" - exts = if null cFlags then [] else [mkExtension False (ExtKeyUsage cFlags)] - --- | Tests 'checkLeafKeyPurpose'. -testLeafKeyPurpose :: IO (RData pub priv) -- ^ Common test resources - -> TestName -- ^ Case name - -> [ExtKeyUsagePurpose] -- ^ Certificate flags - -> [ExtKeyUsagePurpose] -- ^ Flags required for validation - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testLeafKeyPurpose res caseName cFlags vFlags expected = testWithRes res caseName $ \rd -> do - pair <- mkCertificate 2 100 dn (present rd) exts (CA $ intermediate rd) (keys1 rd) - assertValidationResult rd checks "key-purpose" [pair, intermediate rd] expected - where - checks = defaultChecks { checkLeafKeyPurpose = vFlags } - dn = mkDn "key-purpose" - exts = if null cFlags then [] else [mkExtension False (ExtExtendedKeyUsage cFlags)] - --- | Tests validation with multiple failure reasons in exhaustive mode. -testExhaustive :: IO (RData pub priv) -- ^ Common test resources - -> String -- ^ Certificate CommonName - -> HostName -- ^ Connection identification - -> [FailedReason] -- ^ Expected validation result - -> TestTree -testExhaustive res cn hostname expected = testWithRes res caseName $ \rd -> do - -- build an expired self-signed certificate with an invalid signature: - -- the certificate is actually signed by a clone using a different key - p1 <- mkLeaf cn (past rd) Self (keys1 rd) - p2 <- mkLeaf cn (past rd) (CA p1) (keys2 rd) - assertValidationResult rd checks hostname [p2] expected - where - caseName = if null hostname then "empty" else hostname - checks = defaultChecks { checkExhaustive = True } - - --- | All validation test cases. -treeWithAlg :: TestName -> Alg pub priv -> TestTree -treeWithAlg groupName alg = withResource (initData alg) freeData $ \res -> - testGroup groupName - [ testGroup "signature" - [ testSignature res "valid" intermediate intermediate [] - , testSignature res "invalid" intermediate intermediate0 [InvalidSignature SignatureInvalid] - ] - , testGroup "chain" - [ testEmpty res "empty" [EmptyChain] - , testIncompleteChain res "incomplete" [UnknownCA] - , testSelfSigned res "self-signed" [SelfSigned] - , testGroup "leaf-not-v3" - [ testLeafNotV3 res "v3-disallowed" True [LeafNotV3] - , testLeafNotV3 res "v3-allowed" False [] - ] - , testGroup "strict-ordering" - [ testStrictOrdering res "enabled" True [UnknownCA] - , testStrictOrdering res "disabled" False [] - ] - ] - , testGroup "ca-constraints" - [ testGroup "enabled" - [ testCAKeyUsage res "cert-sign" True KeyUsage_keyCertSign [] - , testCAKeyUsage res "crl-sign" True KeyUsage_cRLSign [NotAllowedToSign] - , testNotCA res "not-ca" True [NotAnAuthority] - , testNoBasic res "no-basic" True [NotAnAuthority] - , testBadDepth res "bad-depth" True [AuthorityTooDeep] - ] - , testGroup "disabled" - [ testCAKeyUsage res "cert-sign" False KeyUsage_keyCertSign [] - , testCAKeyUsage res "crl-sign" False KeyUsage_cRLSign [] - , testNotCA res "not-ca" False [] - , testNoBasic res "no-basic" False [] - , testBadDepth res "bad-depth" False [] - ] - ] - , testGroup "dates" - [ testGroup "leaf" - [ testGroup "enabled" - [ testLeafDates res "past" True past [Expired] - , testLeafDates res "present" True present [] - , testLeafDates res "future" True future [InFuture] - ] - , testGroup "disabled" - [ testLeafDates res "past" False past [] - , testLeafDates res "present" False present [] - , testLeafDates res "future" False future [] - ] - ] - , testGroup "intermediate" - [ testGroup "enabled" - [ testIntermediateDates res "past" True intermediatePast [Expired] - , testIntermediateDates res "present" True intermediate [] - , testIntermediateDates res "future" True intermediateFuture [InFuture] - ] - , testGroup "disabled" - [ testIntermediateDates res "past" False intermediatePast [] - , testIntermediateDates res "present" False intermediate [] - , testIntermediateDates res "future" False intermediateFuture [] - ] - ] - , testGroup "timeshift" - [ testGroup "at-past" - [ testTimeshift res "past" past intermediatePast pastDate [] - , testTimeshift res "present" present intermediate pastDate [InFuture] - , testTimeshift res "future" future intermediateFuture pastDate [InFuture] - ] - , testGroup "at-present" - [ testTimeshift res "past" past intermediatePast presentDate [Expired] - , testTimeshift res "present" present intermediate presentDate [] - , testTimeshift res "future" future intermediateFuture presentDate [InFuture] - ] - , testGroup "in-future" - [ testTimeshift res "past" past intermediatePast futureDate [Expired] - , testTimeshift res "present" present intermediate futureDate [Expired] - , testTimeshift res "future" future intermediateFuture futureDate [] - ] - ] - ] - , testGroup "CommonName" - [ testNoCommonName res "no-common-name" [NoCommonName] - , testGroup "simple" - [ testCommonName res "www.example.com" "www.example.com" True [] - , testCommonName res "www.example.com" "www2.example.com" True [NameMismatch "www2.example.com"] - , testCommonName res "www.example.com" "WWW.EXAMPLE.COM" True [] - , testCommonName res "www.example.com" "www.EXAMPLE.COM" True [] - , testCommonName res "www.example.com" "WWW.example.com" True [] - , testCommonName res "www..example.com" "www..example.com" True [NameMismatch "www..example.com"] -- InvalidName "www..example.com" - , testCommonName res "" "" True [NameMismatch ""] -- InvalidName "" - ] - , testGroup "wildcard" - [ testCommonName res "*.example.com" "example.com" True [NameMismatch "example.com"] - , testCommonName res "*.example.com" "www.example.com" True [] - , testCommonName res "*.example.com" "www.EXAMPLE.com" True [] - , testCommonName res "*.example.com" "www2.example.com" True [] - , testCommonName res "*.example.com" "www.m.example.com" True [NameMismatch "www.m.example.com"] - , testCommonName res "*" "single" True [NameMismatch "single"] -- InvalidWildcard - ] - , testGroup "disabled" - [ testCommonName res "www.example.com" "www.example.com" False [] - , testCommonName res "www.example.com" "www2.example.com" False [] - , testCommonName res "www.example.com" "WWW.EXAMPLE.COM" False [] - , testCommonName res "www.example.com" "www.EXAMPLE.COM" False [] - , testCommonName res "www.example.com" "WWW.example.com" False [] - , testCommonName res "www..example.com" "www..example.com" False [] - , testCommonName res "" "" False [] - ] - ] - , testGroup "SubjectAltName" - [ testGroup "simple" - [ testSubjectAltName res "www.example.com" "www.example.com" True [] - , testSubjectAltName res "www.example.com" "www2.example.com" True [NameMismatch "www2.example.com"] - , testSubjectAltName res "www.example.com" "WWW.EXAMPLE.COM" True [] - , testSubjectAltName res "www.example.com" "www.EXAMPLE.COM" True [] - , testSubjectAltName res "www.example.com" "WWW.example.com" True [] - , testSubjectAltName res "www..example.com" "www..example.com" True [NameMismatch "www..example.com"] -- InvalidName "www..example.com" - , testSubjectAltName res "" "" True [NameMismatch ""] -- InvalidName "" - ] - , testGroup "wildcard" - [ testSubjectAltName res "*.example.com" "example.com" True [NameMismatch "example.com"] - , testSubjectAltName res "*.example.com" "www.example.com" True [] - , testSubjectAltName res "*.example.com" "www.EXAMPLE.com" True [] - , testSubjectAltName res "*.example.com" "www2.example.com" True [] - , testSubjectAltName res "*.example.com" "www.m.example.com" True [NameMismatch "www.m.example.com"] - , testSubjectAltName res "*" "single" True [NameMismatch "single"] -- InvalidWildcard - ] - , testSubjectAltName res "www.example.com" "cn-not-used" True [NameMismatch "cn-not-used"] - , testGroup "disabled" - [ testSubjectAltName res "www.example.com" "www.example.com" False [] - , testSubjectAltName res "www.example.com" "www2.example.com" False [] - , testSubjectAltName res "www.example.com" "WWW.EXAMPLE.COM" False [] - , testSubjectAltName res "www.example.com" "www.EXAMPLE.COM" False [] - , testSubjectAltName res "www.example.com" "WWW.example.com" False [] - , testSubjectAltName res "www..example.com" "www..example.com" False [] - , testSubjectAltName res "" "" False [] - ] - ] - , testGroup "key-usage" - [ testLeafKeyUsage res "none" [] [u2, u3] [] - , testLeafKeyUsage res "valid" [u1, u2, u3] [u2, u3] [] - , testLeafKeyUsage res "invalid" [u1, u3] [u2, u3] [LeafKeyUsageNotAllowed] - ] - , testGroup "key-purpose" - [ testLeafKeyPurpose res "none" [] [p2, p3] [] - , testLeafKeyPurpose res "valid" [p1, p2, p3] [p2, p3] [] - , testLeafKeyPurpose res "invalid" [p1, p3] [p2, p3] [LeafKeyPurposeNotAllowed] - ] - , testExhaustive res "exhaustive2" "exhaustive" - [ SelfSigned - , Expired - , InvalidSignature SignatureInvalid - , NameMismatch "exhaustive" - ] - ] - where - (u1, u2, u3) = (KeyUsage_keyEncipherment, KeyUsage_dataEncipherment, KeyUsage_keyAgreement) - (p1, p2, p3) = (KeyUsagePurpose_ClientAuth, KeyUsagePurpose_CodeSigning, KeyUsagePurpose_EmailProtection) - --- | Runs the test suite. -main :: IO () -main = defaultMain $ testGroup "Validation" - [ treeWithAlg "RSA" (AlgRSA 2048 hashSHA256) - , treeWithAlg "RSAPSS" (AlgRSAPSS 2048 pssParams hashSHA224) - , treeWithAlg "DSA" (AlgDSA dsaParams hashSHA1) - , treeWithAlg "ECDSA" (AlgEC curveName hashSHA512) - , treeWithAlg "Ed25519" AlgEd25519 - , treeWithAlg "Ed448" AlgEd448 - ] - where - pssParams = PSS.defaultPSSParams SHA224 - -- DSA parameters were generated using 'openssl dsaparam -C 2048' - dsaParams = DSA.Params - { DSA.params_p = 0x9994B9B1FC22EC3A5F607B5130D314F35FC8D387015A6D8FA2B56D3CC1F13FE330A631DBC765CEFFD6986BDEB8512580BBAD93D56EE7A8997DB9C65C29313FBC5077DB6F1E9D9E6D3499F997F09C8CF8ECC9E5F38DC34C3D656CFDF463893DDF9E246E223D7E5C4E86F54426DDA5DE112FCEDBFB5B6D6F7C76ED190EA1A7761CA561E8E5803F9D616DAFF25E2CCD4011A6D78D5CE8ED28CC2D865C7EC01508BA96FBD1F8BB5E517B6A5208A90AC2D3DCAE50281C02510B86C16D449465CD4B3754FD91AA19031282122A25C68292F033091FCB9DEBDE0D220F81F7EE4AB6581D24BE48204AF3DA52BDB944DA53B76148055395B30954735DC911574D360C953B - , DSA.params_g = 0x10E51AEA37880C5E52DD477ED599D55050C47012D038B9E4B3199C9DE9A5B873B1ABC8B954F26AFEA6C028BCE1783CFE19A88C64E4ED6BFD638802A78457A5C25ABEA98BE9C6EF18A95504C324315EABE7C1EA50E754591E3EFD3D33D4AE47F82F8978ABC871C135133767ACC60683F065430C749C43893D73596B12D5835A78778D0140B2F63B32A5658308DD5BA6BBC49CF6692929FA6A966419404F9A2C216860E3F339EDDB49AD32C294BDB4C9C6BB0D1CC7B691C65968C3A0A5106291CD3810147C8A16B4BFE22968AD9D3890733F4AA9ACD8687A5B981653A4B1824004639956E8C1EDAF31A8224191E8ABD645D2901F5B164B4B93F98039A6EAEC6088 - , DSA.params_q = 0xE1FDFADD32F46B5035EEB3DB81F9974FBCA69BE2223E62FCA8C77989B2AACDF7 - } +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.ECC.Types as ECC +import qualified Crypto.PubKey.RSA.PSS as PSS + +import Data.Default +import Data.Monoid +import Data.String (fromString) +import Data.X509 +import Data.X509.CertificateStore +import Data.X509.Validation + +import Data.Hourglass +import System.Hourglass + +import Test.Tasty +import Test.Tasty.HUnit + +import Certificate + +-- Runtime data, dynamically generated and shared by all test cases -- + +data RData pub priv = RData + { rootStore :: CertificateStore + , past :: (DateTime, DateTime) + , present :: (DateTime, DateTime) + , future :: (DateTime, DateTime) + , pastDate :: DateTime + , presentDate :: DateTime + , futureDate :: DateTime + , root :: Pair pub priv + , intermediate :: Pair pub priv + , intermediate0 :: Pair pub priv + , intermediatePast :: Pair pub priv + , intermediateFuture :: Pair pub priv + , keys1 :: Keys pub priv + , keys2 :: Keys pub priv + , keys3 :: Keys pub priv + } + +mkDateTime :: Date -> DateTime +mkDateTime d = DateTime d (TimeOfDay 0 0 0 0) + +mkStore :: [Pair pub priv] -> CertificateStore +mkStore ps = makeCertificateStore (map pairSignedCert ps) + +initData :: Alg pub priv -> IO (RData pub priv) +initData alg = do + today <- timeGetDate <$> timeCurrent + + let m3 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = -3} + let m2 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = -2} + let m1 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = -1} + let n1 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = 1} + let n2 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = 2} + let n3 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = 3} + + -- two-year validity periods in past, present and future + let vPast = (m3, m1) -- Year-3 .. Year-1 + let vPresent = (m1, n1) -- Year-1 .. Year+1 + let vFuture = (n1, n3) -- Year+1 .. Year+3 + + -- CA basic constraints and key usage extensions + let bc = Just $ ExtBasicConstraints True Nothing + let bc0 = Just $ ExtBasicConstraints True (Just 0) + let ku = Nothing + + -- Root CAs in past, present and future. Need distinct DNs because the + -- certificate store contains all 3 simultaneously. + rootPast <- + generateKeys alg >>= mkCA 1 "RootCA - R1" vPast bc ku Self + rootPresent <- + generateKeys alg >>= mkCA 2 "RootCA - R2" vPresent bc ku Self + rootFuture <- + generateKeys alg >>= mkCA 3 "RootCA - R3" vFuture bc ku Self + + -- Intermediate CAs in past, present and future. Also includes a CA with + -- a depth constraint. + pIntermediateP <- + generateKeys alg >>= mkCA 11 "IntermediateCA" vPast bc ku (CA rootPast) + pIntermediate <- + generateKeys alg >>= mkCA 12 "IntermediateCA" vPresent bc ku (CA rootPresent) + pIntermediate0 <- + generateKeys alg >>= mkCA 12 "IntermediateCA" vPresent bc0 ku (CA rootPresent) + pIntermediateF <- + generateKeys alg >>= mkCA 13 "IntermediateCA" vFuture bc ku (CA rootFuture) + + -- Additional keys to be reused in test cases. This removes the cost of + -- generating individual keys. A key should be used only once per case. + k1 <- generateKeys alg + k2 <- generateKeys alg + k3 <- generateKeys alg + + return + RData + { rootStore = mkStore [rootPast, rootPresent, rootFuture] + , past = vPast + , present = vPresent + , future = vFuture + , pastDate = m2 -- Year-2 + , presentDate = mkDateTime today + , futureDate = n2 -- Year+2 + , root = rootPresent + , intermediate = pIntermediate + , intermediate0 = pIntermediate0 + , intermediatePast = pIntermediateP + , intermediateFuture = pIntermediateF + , keys1 = k1 + , keys2 = k2 + , keys3 = k3 + } + +freeData :: RData pub priv -> IO () +freeData _ = return () + +-- Test utilities -- + +-- | Asserts order-insensitive equality for lists. This also ignores +-- duplicate elements. +assertEqualList + :: (Eq a, Show a) + => String + -- ^ The message prefix + -> [a] + -- ^ The expected value + -> [a] + -- ^ The actual value + -> Assertion +assertEqualList preface expected actual = + unless (actual `same` expected) (assertFailure msg) + where + a `same` b = all (`elem` b) a && all (`elem` a) b + msg = + (if null preface then "" else preface ++ "\n") + ++ " expected: " + ++ show expected + ++ "\n but got: " + ++ show actual + +-- | Asserts the validation result of a certificate chain. +assertValidationResult + :: RData pub priv + -- ^ Common test resources (CA store) + -> ValidationChecks + -- ^ Checks to do + -> HostName + -- ^ Connection identification + -> [Pair pub priv] + -- ^ Certificate chain to validate + -> [FailedReason] + -- ^ Expected validation result + -> Assertion +assertValidationResult rd checks hostname ps expected = do + actual <- validate HashSHA256 defaultHooks checks store def ident chain + assertEqualList "Unexpected validation result" expected actual + where + store = rootStore rd + ident = (hostname, fromString ":443") + chain = CertificateChain (map pairSignedCert ps) + +-- | Simplified access to test resource from 'withResource'. +testWithRes :: IO r -> TestName -> (r -> Assertion) -> TestTree +testWithRes res caseName f = testCase caseName (res >>= f) + +-- Test cases -- + +-- | Tests a leaf certificate signed by an intermediate CA, but using a chain +-- where the intermediate CA may use a different key. This tests the signature +-- of the leaf certificate provided both CAs have the same subject DN. +testSignature + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> (RData pub priv -> Pair pub priv) + -- ^ CA to use for signature + -> (RData pub priv -> Pair pub priv) + -- ^ CA to use for validation + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testSignature res caseName f g expected = testWithRes res caseName $ \rd -> do + pair <- mkLeaf "signature" (present rd) (CA $ f rd) (keys1 rd) + assertValidationResult rd defaultChecks "signature" [pair, g rd] expected + +-- | Tests an empty certificate chain. +testEmpty + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testEmpty res caseName expected = testWithRes res caseName $ \rd -> + assertValidationResult rd defaultChecks "empty" [] expected + +-- | Tests a certificate chain where the intermediate CA is missing. +testIncompleteChain + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testIncompleteChain res caseName expected = testWithRes res caseName $ \rd -> do + pair <- mkLeaf "incomplete" (present rd) (CA $ intermediate rd) (keys1 rd) + assertValidationResult rd defaultChecks "incomplete" [pair] expected + +-- | Tests a self-signed certificate. +testSelfSigned + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testSelfSigned res caseName expected = testWithRes res caseName $ \rd -> do + pair <- mkLeaf "self-signed" (present rd) Self (keys1 rd) + assertValidationResult rd defaultChecks "self-signed" [pair] expected + +-- | Tests key usage of intermediate CA, with or without 'checkCAConstraints'. +testCAKeyUsage + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> Bool + -- ^ Value for 'checkCAConstraints' + -> ExtKeyUsageFlag + -- ^ Intermediate CA key usage + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testCAKeyUsage res caseName check flag expected = testWithRes res caseName $ \rd -> do + ca <- mkCA 20 "KeyUsageCA" (present rd) bc ku (CA $ root rd) (keys1 rd) + pair <- mkLeaf "ca-key-usage" (present rd) (CA ca) (keys2 rd) + assertValidationResult rd checks "ca-key-usage" [pair, ca] expected + where + checks = defaultChecks{checkCAConstraints = check} + bc = Just (ExtBasicConstraints True Nothing) + ku = Just (ExtKeyUsage [flag]) + +-- | Tests CA flag of intermediate CA, with or without 'checkCAConstraints'. +testNotCA + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> Bool + -- ^ Value for 'checkCAConstraints' + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testNotCA res caseName check expected = testWithRes res caseName $ \rd -> do + ca <- mkCA 20 "NotCA" (present rd) bc Nothing (CA $ root rd) (keys1 rd) + pair <- mkLeaf "not-ca" (present rd) (CA ca) (keys2 rd) + assertValidationResult rd checks "not-ca" [pair, ca] expected + where + checks = defaultChecks{checkCAConstraints = check} + bc = Just (ExtBasicConstraints False Nothing) + +-- | Tests an intermediate CA without basic constraints, with or without +-- 'checkCAConstraints'. +testNoBasic + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> Bool + -- ^ Value for 'checkCAConstraints' + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testNoBasic res caseName check expected = testWithRes res caseName $ \rd -> do + ca <- mkCA 20 "NoBC" (present rd) bc Nothing (CA $ root rd) (keys1 rd) + pair <- mkLeaf "no-bc" (present rd) (CA ca) (keys2 rd) + assertValidationResult rd checks "no-bc" [pair, ca] expected + where + checks = defaultChecks{checkCAConstraints = check} + bc = Nothing + +-- | Tests basic constraints depth, with or without 'checkCAConstraints'. +testBadDepth + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> Bool + -- ^ Value for 'checkCAConstraints' + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testBadDepth res caseName check expected = testWithRes res caseName $ \rd -> do + -- a new CA signed by intermediate0 should fail because of the depth limit + ca <- + mkCA 20 "TooDeep" (present rd) bc Nothing (CA $ intermediate0 rd) (keys1 rd) + pair <- mkLeaf "bad-depth" (present rd) (CA ca) (keys2 rd) + assertValidationResult + rd + checks + "bad-depth" + [pair, ca, intermediate0 rd] + expected + where + checks = defaultChecks{checkCAConstraints = check} + bc = Just (ExtBasicConstraints True Nothing) + +-- | Tests a non-V3 leaf certificate, with or without 'checkLeafV3'. +testLeafNotV3 + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> Bool + -- ^ Value for 'checkLeafV3' + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testLeafNotV3 res caseName check expected = testWithRes res caseName $ \rd -> do + pair <- + mkCertificate + 1 + 100 + dn + (present rd) + leafStdExts + (CA $ intermediate rd) + (keys1 rd) + assertValidationResult rd checks "leaf-not-v3" [pair, intermediate rd] expected + where + checks = defaultChecks{checkLeafV3 = check} + dn = mkDn "leaf-not-v3" + +-- | Tests a certificate chain containing a non-related certificate, with or +-- without 'checkStrictOrdering'. +testStrictOrdering + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> Bool + -- ^ Value for 'checkStrictOrdering' + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testStrictOrdering res caseName check expected = testWithRes res caseName $ \rd -> do + ca <- + mkCA 20 "CA" (present rd) bc Nothing (CA $ intermediate rd) (keys1 rd) + extra <- + mkCA 21 "Extra" (present rd) bc Nothing (CA $ intermediate rd) (keys2 rd) + pair <- mkLeaf "strict-ordering" (present rd) (CA ca) (keys3 rd) + assertValidationResult + rd + checks + "strict-ordering" + [pair, ca, extra, intermediate rd] + expected + where + checks = defaultChecks{checkStrictOrdering = check} + bc = Just (ExtBasicConstraints True Nothing) + +-- | Tests validity of leaf certificate. +testLeafDates + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> Bool + -- ^ Value for 'checkTimeValidity' + -> (RData pub priv -> (DateTime, DateTime)) + -- ^ Validity period to use + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testLeafDates res caseName check f expected = testWithRes res caseName $ \rd -> do + pair <- mkLeaf "leaf-dates" (f rd) (CA $ intermediate rd) (keys1 rd) + assertValidationResult rd checks "leaf-dates" [pair, intermediate rd] expected + where + checks = defaultChecks{checkTimeValidity = check} + +-- | Tests validity of intermediate CA. +testIntermediateDates + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> Bool + -- ^ Value for 'checkTimeValidity' + -> (RData pub priv -> Pair pub priv) + -- ^ Intermediate CA to use + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testIntermediateDates res caseName check f expected = testWithRes res caseName $ \rd -> do + pair <- mkLeaf "intermediate-dates" (present rd) (CA $ f rd) (keys1 rd) + assertValidationResult rd checks "intermediate-dates" [pair, f rd] expected + where + checks = defaultChecks{checkTimeValidity = check} + +-- | Tests validity of leaf certificate and intermediate CA, +-- using 'checkAtTime'. +testTimeshift + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> (RData pub priv -> (DateTime, DateTime)) + -- ^ Leaf validity period + -> (RData pub priv -> Pair pub priv) + -- ^ Intermediate CA to use + -> (RData pub priv -> DateTime) + -- ^ Value for 'checkAtTime' + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testTimeshift res caseName f g h expected = testWithRes res caseName $ \rd -> do + let checks = defaultChecks{checkAtTime = Just $ h rd} + pair <- mkLeaf "timeshift" (f rd) (CA $ g rd) (keys1 rd) + assertValidationResult rd checks "timeshift" [pair, g rd] expected + +-- | Tests an empty DistinguishedName. +testNoCommonName + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testNoCommonName res caseName expected = testWithRes res caseName $ \rd -> do + pair <- + mkCertificate + 2 + 100 + dn + (present rd) + leafStdExts + (CA $ intermediate rd) + (keys1 rd) + assertValidationResult rd defaultChecks "no-cn" [pair, intermediate rd] expected + where + dn = DistinguishedName [] + +-- | Tests certificate CommonName against expected hostname, with or without +-- 'checkFQHN'. +testCommonName + :: IO (RData pub priv) + -- ^ Common test resources + -> String + -- ^ Certificate CommonName + -> HostName + -- ^ Connection identification + -> Bool + -- ^ Value for 'checkFQHN' + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testCommonName res cn hostname check expected = testWithRes res caseName $ \rd -> do + pair <- mkLeaf cn (present rd) (CA $ intermediate rd) (keys1 rd) + assertValidationResult rd checks hostname [pair, intermediate rd] expected + where + caseName = if null hostname then "empty" else hostname + checks = defaultChecks{checkFQHN = check} + +-- | Tests certificate SubjectAltName against expected hostname, with or +-- without 'checkFQHN'. +testSubjectAltName + :: IO (RData pub priv) + -- ^ Common test resources + -> String + -- ^ Certificate SubjectAltName + -> HostName + -- ^ Connection identification + -> Bool + -- ^ Value for 'checkFQHN' + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testSubjectAltName res san hostname check expected = testWithRes res caseName $ \rd -> do + pair <- + mkCertificate + 2 + 100 + dn + (present rd) + (ext : leafStdExts) + (CA $ intermediate rd) + (keys1 rd) + assertValidationResult rd checks hostname [pair, intermediate rd] expected + where + caseName = if null hostname then "empty" else hostname + checks = defaultChecks{checkFQHN = check} + dn = mkDn "cn-not-used" -- this CN value is to be tested too + -- (to make sure CN is *not* considered when a + -- SubjectAltName exists) + ext = + mkExtension False $ + -- wraps test value with other values + ExtSubjectAltName + [ AltNameDNS "dummy1" + , AltNameRFC822 "test@example.com" + , AltNameDNS san + , AltNameDNS "dummy2" + ] + +-- | Tests 'checkLeafKeyUsage'. +testLeafKeyUsage + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> [ExtKeyUsageFlag] + -- ^ Certificate flags + -> [ExtKeyUsageFlag] + -- ^ Flags required for validation + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testLeafKeyUsage res caseName cFlags vFlags expected = testWithRes res caseName $ \rd -> do + pair <- + mkCertificate 2 100 dn (present rd) exts (CA $ intermediate rd) (keys1 rd) + assertValidationResult rd checks "key-usage" [pair, intermediate rd] expected + where + checks = defaultChecks{checkLeafKeyUsage = vFlags} + dn = mkDn "key-usage" + exts = if null cFlags then [] else [mkExtension False (ExtKeyUsage cFlags)] + +-- | Tests 'checkLeafKeyPurpose'. +testLeafKeyPurpose + :: IO (RData pub priv) + -- ^ Common test resources + -> TestName + -- ^ Case name + -> [ExtKeyUsagePurpose] + -- ^ Certificate flags + -> [ExtKeyUsagePurpose] + -- ^ Flags required for validation + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testLeafKeyPurpose res caseName cFlags vFlags expected = testWithRes res caseName $ \rd -> do + pair <- + mkCertificate 2 100 dn (present rd) exts (CA $ intermediate rd) (keys1 rd) + assertValidationResult rd checks "key-purpose" [pair, intermediate rd] expected + where + checks = defaultChecks{checkLeafKeyPurpose = vFlags} + dn = mkDn "key-purpose" + exts = if null cFlags then [] else [mkExtension False (ExtExtendedKeyUsage cFlags)] + +-- | Tests validation with multiple failure reasons in exhaustive mode. +testExhaustive + :: IO (RData pub priv) + -- ^ Common test resources + -> String + -- ^ Certificate CommonName + -> HostName + -- ^ Connection identification + -> [FailedReason] + -- ^ Expected validation result + -> TestTree +testExhaustive res cn hostname expected = testWithRes res caseName $ \rd -> do + -- build an expired self-signed certificate with an invalid signature: + -- the certificate is actually signed by a clone using a different key + p1 <- mkLeaf cn (past rd) Self (keys1 rd) + p2 <- mkLeaf cn (past rd) (CA p1) (keys2 rd) + assertValidationResult rd checks hostname [p2] expected + where + caseName = if null hostname then "empty" else hostname + checks = defaultChecks{checkExhaustive = True} + +-- | All validation test cases. +treeWithAlg :: TestName -> Alg pub priv -> TestTree +treeWithAlg groupName alg = withResource (initData alg) freeData $ \res -> + testGroup + groupName + [ testGroup + "signature" + [ testSignature res "valid" intermediate intermediate [] + , testSignature + res + "invalid" + intermediate + intermediate0 + [InvalidSignature SignatureInvalid] + ] + , testGroup + "chain" + [ testEmpty res "empty" [EmptyChain] + , testIncompleteChain res "incomplete" [UnknownCA] + , testSelfSigned res "self-signed" [SelfSigned] + , testGroup + "leaf-not-v3" + [ testLeafNotV3 res "v3-disallowed" True [LeafNotV3] + , testLeafNotV3 res "v3-allowed" False [] + ] + , testGroup + "strict-ordering" + [ testStrictOrdering res "enabled" True [UnknownCA] + , testStrictOrdering res "disabled" False [] + ] + ] + , testGroup + "ca-constraints" + [ testGroup + "enabled" + [ testCAKeyUsage res "cert-sign" True KeyUsage_keyCertSign [] + , testCAKeyUsage res "crl-sign" True KeyUsage_cRLSign [NotAllowedToSign] + , testNotCA res "not-ca" True [NotAnAuthority] + , testNoBasic res "no-basic" True [NotAnAuthority] + , testBadDepth res "bad-depth" True [AuthorityTooDeep] + ] + , testGroup + "disabled" + [ testCAKeyUsage res "cert-sign" False KeyUsage_keyCertSign [] + , testCAKeyUsage res "crl-sign" False KeyUsage_cRLSign [] + , testNotCA res "not-ca" False [] + , testNoBasic res "no-basic" False [] + , testBadDepth res "bad-depth" False [] + ] + ] + , testGroup + "dates" + [ testGroup + "leaf" + [ testGroup + "enabled" + [ testLeafDates res "past" True past [Expired] + , testLeafDates res "present" True present [] + , testLeafDates res "future" True future [InFuture] + ] + , testGroup + "disabled" + [ testLeafDates res "past" False past [] + , testLeafDates res "present" False present [] + , testLeafDates res "future" False future [] + ] + ] + , testGroup + "intermediate" + [ testGroup + "enabled" + [ testIntermediateDates res "past" True intermediatePast [Expired] + , testIntermediateDates res "present" True intermediate [] + , testIntermediateDates res "future" True intermediateFuture [InFuture] + ] + , testGroup + "disabled" + [ testIntermediateDates res "past" False intermediatePast [] + , testIntermediateDates res "present" False intermediate [] + , testIntermediateDates res "future" False intermediateFuture [] + ] + ] + , testGroup + "timeshift" + [ testGroup + "at-past" + [ testTimeshift res "past" past intermediatePast pastDate [] + , testTimeshift res "present" present intermediate pastDate [InFuture] + , testTimeshift res "future" future intermediateFuture pastDate [InFuture] + ] + , testGroup + "at-present" + [ testTimeshift res "past" past intermediatePast presentDate [Expired] + , testTimeshift res "present" present intermediate presentDate [] + , testTimeshift res "future" future intermediateFuture presentDate [InFuture] + ] + , testGroup + "in-future" + [ testTimeshift res "past" past intermediatePast futureDate [Expired] + , testTimeshift res "present" present intermediate futureDate [Expired] + , testTimeshift res "future" future intermediateFuture futureDate [] + ] + ] + ] + , testGroup + "CommonName" + [ testNoCommonName res "no-common-name" [NoCommonName] + , testGroup + "simple" + [ testCommonName res "www.example.com" "www.example.com" True [] + , testCommonName + res + "www.example.com" + "www2.example.com" + True + [NameMismatch "www2.example.com"] + , testCommonName res "www.example.com" "WWW.EXAMPLE.COM" True [] + , testCommonName res "www.example.com" "www.EXAMPLE.COM" True [] + , testCommonName res "www.example.com" "WWW.example.com" True [] + , testCommonName + res + "www..example.com" + "www..example.com" + True + [NameMismatch "www..example.com"] -- InvalidName "www..example.com" + , testCommonName res "" "" True [NameMismatch ""] -- InvalidName "" + ] + , testGroup + "wildcard" + [ testCommonName + res + "*.example.com" + "example.com" + True + [NameMismatch "example.com"] + , testCommonName res "*.example.com" "www.example.com" True [] + , testCommonName res "*.example.com" "www.EXAMPLE.com" True [] + , testCommonName res "*.example.com" "www2.example.com" True [] + , testCommonName + res + "*.example.com" + "www.m.example.com" + True + [NameMismatch "www.m.example.com"] + , testCommonName + res + "*" + "single" + True + [NameMismatch "single"] -- InvalidWildcard + ] + , testGroup + "disabled" + [ testCommonName res "www.example.com" "www.example.com" False [] + , testCommonName res "www.example.com" "www2.example.com" False [] + , testCommonName res "www.example.com" "WWW.EXAMPLE.COM" False [] + , testCommonName res "www.example.com" "www.EXAMPLE.COM" False [] + , testCommonName res "www.example.com" "WWW.example.com" False [] + , testCommonName res "www..example.com" "www..example.com" False [] + , testCommonName res "" "" False [] + ] + ] + , testGroup + "SubjectAltName" + [ testGroup + "simple" + [ testSubjectAltName res "www.example.com" "www.example.com" True [] + , testSubjectAltName + res + "www.example.com" + "www2.example.com" + True + [NameMismatch "www2.example.com"] + , testSubjectAltName res "www.example.com" "WWW.EXAMPLE.COM" True [] + , testSubjectAltName res "www.example.com" "www.EXAMPLE.COM" True [] + , testSubjectAltName res "www.example.com" "WWW.example.com" True [] + , testSubjectAltName + res + "www..example.com" + "www..example.com" + True + [NameMismatch "www..example.com"] -- InvalidName "www..example.com" + , testSubjectAltName + res + "" + "" + True + [NameMismatch ""] -- InvalidName "" + ] + , testGroup + "wildcard" + [ testSubjectAltName + res + "*.example.com" + "example.com" + True + [NameMismatch "example.com"] + , testSubjectAltName res "*.example.com" "www.example.com" True [] + , testSubjectAltName res "*.example.com" "www.EXAMPLE.com" True [] + , testSubjectAltName res "*.example.com" "www2.example.com" True [] + , testSubjectAltName + res + "*.example.com" + "www.m.example.com" + True + [NameMismatch "www.m.example.com"] + , testSubjectAltName + res + "*" + "single" + True + [NameMismatch "single"] -- InvalidWildcard + ] + , testSubjectAltName + res + "www.example.com" + "cn-not-used" + True + [NameMismatch "cn-not-used"] + , testGroup + "disabled" + [ testSubjectAltName res "www.example.com" "www.example.com" False [] + , testSubjectAltName res "www.example.com" "www2.example.com" False [] + , testSubjectAltName res "www.example.com" "WWW.EXAMPLE.COM" False [] + , testSubjectAltName res "www.example.com" "www.EXAMPLE.COM" False [] + , testSubjectAltName res "www.example.com" "WWW.example.com" False [] + , testSubjectAltName res "www..example.com" "www..example.com" False [] + , testSubjectAltName res "" "" False [] + ] + ] + , testGroup + "key-usage" + [ testLeafKeyUsage res "none" [] [u2, u3] [] + , testLeafKeyUsage res "valid" [u1, u2, u3] [u2, u3] [] + , testLeafKeyUsage res "invalid" [u1, u3] [u2, u3] [LeafKeyUsageNotAllowed] + ] + , testGroup + "key-purpose" + [ testLeafKeyPurpose res "none" [] [p2, p3] [] + , testLeafKeyPurpose res "valid" [p1, p2, p3] [p2, p3] [] + , testLeafKeyPurpose + res + "invalid" + [p1, p3] + [p2, p3] + [LeafKeyPurposeNotAllowed] + ] + , testExhaustive + res + "exhaustive2" + "exhaustive" + [ SelfSigned + , Expired + , InvalidSignature SignatureInvalid + , NameMismatch "exhaustive" + ] + ] + where + (u1, u2, u3) = (KeyUsage_keyEncipherment, KeyUsage_dataEncipherment, KeyUsage_keyAgreement) + (p1, p2, p3) = + ( KeyUsagePurpose_ClientAuth + , KeyUsagePurpose_CodeSigning + , KeyUsagePurpose_EmailProtection + ) + +-- | Runs the test suite. +main :: IO () +main = + defaultMain $ + testGroup + "Validation" + [ treeWithAlg "RSA" (AlgRSA 2048 hashSHA256) + , treeWithAlg "RSAPSS" (AlgRSAPSS 2048 pssParams hashSHA224) + , treeWithAlg "DSA" (AlgDSA dsaParams hashSHA1) + , treeWithAlg "ECDSA" (AlgEC curveName hashSHA512) + , treeWithAlg "Ed25519" AlgEd25519 + , treeWithAlg "Ed448" AlgEd448 + ] + where + pssParams = PSS.defaultPSSParams SHA224 + -- DSA parameters were generated using 'openssl dsaparam -C 2048' + dsaParams = + DSA.Params + { DSA.params_p = + 0x9994B9B1FC22EC3A5F607B5130D314F35FC8D387015A6D8FA2B56D3CC1F13FE330A631DBC765CEFFD6986BDEB8512580BBAD93D56EE7A8997DB9C65C29313FBC5077DB6F1E9D9E6D3499F997F09C8CF8ECC9E5F38DC34C3D656CFDF463893DDF9E246E223D7E5C4E86F54426DDA5DE112FCEDBFB5B6D6F7C76ED190EA1A7761CA561E8E5803F9D616DAFF25E2CCD4011A6D78D5CE8ED28CC2D865C7EC01508BA96FBD1F8BB5E517B6A5208A90AC2D3DCAE50281C02510B86C16D449465CD4B3754FD91AA19031282122A25C68292F033091FCB9DEBDE0D220F81F7EE4AB6581D24BE48204AF3DA52BDB944DA53B76148055395B30954735DC911574D360C953B + , DSA.params_g = + 0x10E51AEA37880C5E52DD477ED599D55050C47012D038B9E4B3199C9DE9A5B873B1ABC8B954F26AFEA6C028BCE1783CFE19A88C64E4ED6BFD638802A78457A5C25ABEA98BE9C6EF18A95504C324315EABE7C1EA50E754591E3EFD3D33D4AE47F82F8978ABC871C135133767ACC60683F065430C749C43893D73596B12D5835A78778D0140B2F63B32A5658308DD5BA6BBC49CF6692929FA6A966419404F9A2C216860E3F339EDDB49AD32C294BDB4C9C6BB0D1CC7B691C65968C3A0A5106291CD3810147C8A16B4BFE22968AD9D3890733F4AA9ACD8687A5B981653A4B1824004639956E8C1EDAF31A8224191E8ABD645D2901F5B164B4B93F98039A6EAEC6088 + , DSA.params_q = + 0xE1FDFADD32F46B5035EEB3DB81F9974FBCA69BE2223E62FCA8C77989B2AACDF7 + } curveName = ECC.SEC_p384r1 diff --git a/crypton-x509-validation.cabal b/crypton-x509-validation.cabal --- a/crypton-x509-validation.cabal +++ b/crypton-x509-validation.cabal @@ -1,5 +1,5 @@ Name: crypton-x509-validation -version: 1.6.12 +version: 1.6.13 Description: X.509 Certificate and CRL validation. please see README License: BSD3 License-file: LICENSE @@ -21,7 +21,7 @@ , mtl , containers , hourglass - , data-default-class + , data-default , pem >= 0.1 , asn1-types >= 0.3 && < 0.4 , asn1-encoding >= 0.9 && < 0.10 @@ -44,7 +44,7 @@ Build-Depends: base >= 3 && < 5 , bytestring , memory - , data-default-class + , data-default , tasty , tasty-hunit , hourglass