crypton-x509-validation 1.6.12 → 1.6.13
raw patch · 9 files changed
+1601/−1179 lines, 9 filesdep +data-defaultdep −data-default-classsetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: data-default
Dependencies removed: data-default-class
API changes (from Hackage documentation)
- Data.X509.Validation: instance Data.Default.Class.Default Data.X509.Validation.ValidationChecks
- Data.X509.Validation: instance Data.Default.Class.Default Data.X509.Validation.ValidationHooks
+ Data.X509.Validation: defaultValidationCache :: ValidationCache
+ Data.X509.Validation: instance Data.Default.Internal.Default Data.X509.Validation.ValidationChecks
+ Data.X509.Validation: instance Data.Default.Internal.Default Data.X509.Validation.ValidationHooks
- Data.X509.Validation: type ValidationCacheAddCallback = ServiceID " connection's identification" -> Fingerprint " fingerprint of the leaf certificate" -> Certificate " leaf certificate" -> IO ()
+ Data.X509.Validation: type ValidationCacheAddCallback = -- | connection's identification ServiceID -> -- | fingerprint of the leaf certificate Fingerprint -> -- | leaf certificate Certificate -> IO ()
- Data.X509.Validation: 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"
+ Data.X509.Validation: type ValidationCacheQueryCallback = -- | connection's identification ServiceID -> -- | fingerprint of the leaf certificate Fingerprint -> -- | leaf certificate Certificate -> -- | return if the operation is succesful or not IO ValidationCacheResult
Files
- Data/X509/Validation.hs +323/−253
- Data/X509/Validation/Cache.hs +65/−39
- Data/X509/Validation/Fingerprint.hs +20/−16
- Data/X509/Validation/Signature.hs +118/−105
- Data/X509/Validation/Types.hs +4/−5
- Setup.hs +1/−0
- Tests/Certificate.hs +205/−170
- Tests/Tests.hs +862/−588
- crypton-x509-validation.cabal +3/−3
Data/X509/Validation.hs view
@@ -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
Data/X509/Validation/Cache.hs view
@@ -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)
Data/X509/Validation/Fingerprint.hs view
@@ -1,37 +1,41 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ -- | -- Module : Data.X509.Validation.Fingerprint -- License : BSD-style -- Maintainer : Vincent Hanquez <vincent@snarc.org> -- 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
Data/X509/Validation/Signature.hs view
@@ -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
Data/X509/Validation/Types.hs view
@@ -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)
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
Tests/Certificate.hs view
@@ -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
Tests/Tests.hs view
@@ -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
crypton-x509-validation.cabal view
@@ -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