crypton-x509-validation (empty) → 1.6.12
raw patch · 10 files changed
+1743/−0 lines, 10 filesdep +asn1-encodingdep +asn1-typesdep +basesetup-changed
Dependencies added: asn1-encoding, asn1-types, base, bytestring, containers, crypton, crypton-x509, crypton-x509-store, crypton-x509-validation, data-default-class, hourglass, memory, mtl, pem, tasty, tasty-hunit
Files
- Data/X509/Validation.hs +406/−0
- Data/X509/Validation/Cache.hs +98/−0
- Data/X509/Validation/Fingerprint.hs +38/−0
- Data/X509/Validation/Signature.hs +163/−0
- Data/X509/Validation/Types.hs +29/−0
- LICENSE +27/−0
- Setup.hs +2/−0
- Tests/Certificate.hs +321/−0
- Tests/Tests.hs +597/−0
- crypton-x509-validation.cabal +62/−0
+ Data/X509/Validation.hs view
@@ -0,0 +1,406 @@+-- |+-- Module : Data.X509.Validation+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- X.509 Certificate checks and validations routines+--+-- Follows RFC5280 / RFC6818+--+module Data.X509.Validation+ (+ module Data.X509.Validation.Types+ , Fingerprint(..)+ -- * Failed validation types+ , FailedReason(..)+ , SignatureFailure(..)+ -- * Validation configuration types+ , ValidationChecks(..)+ , ValidationHooks(..)+ , defaultChecks+ , defaultHooks+ -- * Validation+ , validate+ , validatePure+ , validateDefault+ , getFingerprint+ -- * Cache+ , module Data.X509.Validation.Cache+ -- * Signature verification+ , 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.X509+import Data.X509.CertificateStore+import Data.X509.Validation.Signature+import Data.X509.Validation.Fingerprint+import Data.X509.Validation.Cache+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)++-- | 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.+ -- 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,+ -- the current time will be used+ , checkAtTime :: Maybe DateTime+ -- | Check that no certificate is included that shouldn't be included.+ -- unfortunately despite the specification violation, a lots of+ -- real world server serves useless and usually old certificates+ -- that are not relevant to the certificate sent, in their chain.+ , checkStrictOrdering :: Bool+ -- | Check that signing certificate got the CA basic constraint.+ -- this is absolutely not recommended to turn it off.+ , checkCAConstraints :: Bool+ -- | Check the whole certificate chain without stopping at the first failure.+ -- Allow gathering a exhaustive list of failure reasons. if this is+ -- turn off, it's absolutely not safe to ignore a failed reason even it doesn't look serious+ -- (e.g. Expired) as other more serious checks would not have been performed.+ , checkExhaustive :: Bool+ -- | Check that the leaf certificate is version 3. If disable, version 2 certificate+ -- is authorized in leaf position and key usage cannot be checked.+ , checkLeafV3 :: Bool+ -- | Check that the leaf certificate is authorized to be used for certain usage.+ -- If set to empty list no check are performed, otherwise all the flags is the list+ -- need to exists in the key usage extension. 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.+ -- 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).+ -- it's not recommended to turn this check off, if no other name checks are performed.+ , checkFQHN :: Bool+ } 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+ -- 'DistinguishedName' of a candidate issuer certificate.+ hookMatchSubjectIssuer :: DistinguishedName -> Certificate -> Bool+ -- | 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]+ }++-- | Default checks to perform+--+-- The default checks are:+-- * Each certificate time is valid+-- * CA constraints is enforced for signing certificate+-- * Leaf certificate is X.509 v3+-- * Check that the FQHN match+defaultChecks :: ValidationChecks+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+ }++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 = validate HashSHA256 defaultHooks defaultChecks++-- | X509 validation+--+-- 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 _ _ _ _ _ _ (CertificateChain []) = return [EmptyChain]+validate hashAlg hooks checks store cache ident cc@(CertificateChain (top:_)) = do+ cacheResult <- (cacheQuery cache) ident fingerPrint (getCertificate top)+ case cacheResult of+ ValidationCachePass -> return []+ ValidationCacheDenied s -> return [CacheSaysNo s]+ 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)+ return failedReasons+ 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++ doLeafChecks = doNameCheck top ++ doV3Check topCert ++ doKeyUsageCheck topCert+ where topCert = getCertificate top++ 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 findIssuer (certIssuerDN cert) chain of+ 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++ -- 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)++ 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]++ 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]++-- | 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++getNames :: Certificate -> (Maybe String, [String])+getNames cert = (commonName >>= asn1CharacterToString, altNames)+ where commonName = getDnElement DnCommonName $ certSubjectDN cert+ altNames = maybe [] toAltName $ extensionGet $ certExtensions cert+ toAltName (ExtSubjectAltName names) = catMaybes $ map unAltName names+ where unAltName (AltNameDNS s) = Just s+ unAltName _ = Nothing++-- | Validate that the fqhn is matched by at least one name in the certificate.+-- If the subjectAltname extension is present, then the certificate commonName+-- is ignored, and only the DNS names, if any, in the subjectAltName are+-- considered. Otherwise, the commonName from the subjectDN is used.+--+-- Note that DNS names in the subjectAltName are in IDNA A-label form. If the+-- destination hostname is a UTF-8 name, it must be provided to the TLS context+-- in (non-transitional) IDNA2008 A-label form.+validateCertificateName :: HostName -> Certificate -> [FailedReason]+validateCertificateName fqhn cert+ | not $ null altNames =+ findMatch [] $ map matchDomain altNames+ | otherwise =+ 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++ 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]++ -- 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+matchSI :: DistinguishedName -> Certificate -> Bool+matchSI issuerDN issuer = certSubjectDN issuer == issuerDN++exhaustive :: Bool -> [FailedReason] -> [FailedReason] -> [FailedReason]+exhaustive isExhaustive l1 l2+ | null l1 = l2+ | isExhaustive = l1 ++ l2+ | otherwise = l1++exhaustiveList :: Bool -> [(Bool, [FailedReason])] -> [FailedReason]+exhaustiveList _ [] = []+exhaustiveList isExhaustive ((performCheck,c):cs)+ | performCheck = exhaustive isExhaustive c (exhaustiveList isExhaustive cs)+ | otherwise = exhaustiveList isExhaustive cs
+ Data/X509/Validation/Cache.hs view
@@ -0,0 +1,98 @@+-- |+-- Module : Data.X509.Validation.Cache+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- X.509 Validation cache+--+-- Define all the types necessary for the validation cache,+-- and some simples instances of cache mechanism+module Data.X509.Validation.Cache+ (+ -- * Cache for validation+ ValidationCacheResult(..)+ , ValidationCacheQueryCallback+ , ValidationCacheAddCallback+ , ValidationCache(..)+ -- * Simple instances of cache mechanism+ , exceptionValidationCache+ , tofuValidationCache+ ) where++import Control.Concurrent+import Data.Default.Class+import Data.X509+import Data.X509.Validation.Types+import Data.X509.Validation.Fingerprint++-- | 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)++-- | 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++-- | Validation cache callback type+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+ }++instance Default ValidationCache where+ def = exceptionValidationCache []++-- | create a simple constant cache that list exceptions to the certification+-- validation. Typically this is use to allow self-signed certificates for+-- specific use, with out-of-bounds user checks.+--+-- No fingerprints will be added after the instance is created.+--+-- The underlying structure for the check is kept as a list, as+-- usually the exception list will be short, but when the list go above+-- a dozen exceptions it's recommended to use another cache mechanism with+-- a faster lookup mechanism (hashtable, map, etc).+--+-- Note that only one fingerprint is allowed per ServiceID, for other use,+-- another cache mechanism need to be use.+exceptionValidationCache :: [(ServiceID, Fingerprint)] -> ValidationCache+exceptionValidationCache fingerprints =+ ValidationCache (queryListCallback fingerprints)+ (\_ _ _ -> return ())++-- | Trust on first use (TOFU) cache with an optional list of exceptions+--+-- this is similar to the exceptionCache, except that after+-- 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 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)))++-- | 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)+
+ Data/X509/Validation/Fingerprint.hs view
@@ -0,0 +1,38 @@+-- |+-- 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++import Crypto.Hash+import Data.X509+import Data.ASN1.Types+import Data.ByteArray (convert, ByteArrayAccess)+import Data.ByteString (ByteString)++-- | Fingerprint of a certificate+newtype Fingerprint = Fingerprint ByteString+ 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 sobj halg = Fingerprint $ mkHash halg $ encodeSignedObject sobj+ where+ 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+ mkHash HashSHA512 = convert . hashWith SHA512
+ Data/X509/Validation/Signature.hs view
@@ -0,0 +1,163 @@+-- |+-- Module : Data.X509.Validation.Signature+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- X.509 Certificate and CRL signature verification+--+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 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.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448+import Crypto.Hash++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.+--+-- When SignatureFailed is return, the signature shouldn't be+-- accepted.+--+-- Other values are only useful to differentiate the failure+-- reason, but are all equivalent to failure.+--+data SignatureVerification =+ SignaturePass -- ^ verification succeeded+ | SignatureFailed SignatureFailure -- ^ verification failed+ deriving (Show,Eq)++-- | Various failure possible during signature checking+data SignatureFailure =+ SignatureInvalid -- ^ signature doesn't verify+ | SignaturePubkeyMismatch -- ^ algorithm and public key mismatch, cannot proceed+ | SignatureUnimplemented -- ^ unimplemented signature algorithm+ deriving (Show,Eq)++-- | Verify a Signed object against a specified public key+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++-- | 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_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+ 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+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+ 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++ 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++ eddsa verify toSig key =+ case toSig signature of+ CryptoPassed sig+ | verify key cdata sig -> SignaturePass+ | 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++ 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
@@ -0,0 +1,29 @@+-- |+-- Module : Data.X509.Validation.Types+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- X.509 Validation types+module Data.X509.Validation.Types+ ( ServiceID+ , HostName+ ) where++import Data.ByteString (ByteString)++type HostName = String++-- | identification of the connection consisting of the+-- fully qualified host name (e.g. www.example.com) and+-- an optional suffix.+--+-- The suffix is not used by the validation process, but+-- is used by the optional cache to identity certificate per service+-- on a specific host. For example, one might have a different+-- 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)
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2010-2013 Vincent Hanquez <vincent@snarc.org>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Tests/Certificate.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE GADTs #-}+-- | Types and functions used to build test certificates.+module Certificate+ (+ -- * Hash algorithms+ hashMD2+ , hashMD5+ , hashSHA1+ , hashSHA224+ , hashSHA256+ , hashSHA384+ , hashSHA512+ -- * Key and signature utilities+ , Alg(..)+ , Keys+ , generateKeys+ -- * Certificate utilities+ , Pair(..)+ , mkDn+ , mkExtension+ , leafStdExts+ -- * Certificate creation functions+ , 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.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.RSA.PKCS15 as RSA+import qualified Crypto.PubKey.RSA.PSS as PSS++import qualified Data.ByteString as B++import Data.ASN1.BinaryEncoding (DER(..))+import Data.ASN1.Encoding+import Data.ASN1.Types+import Data.ByteArray (convert)+import Data.Maybe (catMaybes)+import Data.String (fromString)+import Data.X509++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 }++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+hashSHA224 = GHash HashSHA224 SHA224+hashSHA256 = GHash HashSHA256 SHA256+hashSHA384 = GHash HashSHA384 SHA384+hashSHA512 = GHash HashSHA512 SHA512++-- | 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++ AlgEd25519 :: Alg Ed25519.PublicKey Ed25519.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@(AlgRSAPSS bits _ _) = generateRSAKeys alg bits+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+ let curve = ECC.getCurveByName name+ (pub, priv) <- ECC.generate curve+ return (alg, pub, priv)+generateKeys alg@AlgEd25519 = do+ secret <- Ed25519.generateSecretKey+ return (alg, Ed25519.toPublic secret, secret)+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 bits = addAlg <$> RSA.generate size e+ where+ addAlg (pub, priv) = (alg, pub, priv)+ size = bits `div` 8+ 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)+ 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)+ bytes = (bits + 7) `div` 8+getPubKey AlgEd25519 key = PubKeyEd25519 key+getPubKey AlgEd448 key = PubKeyEd448 key++getSignatureALG :: Alg pub priv -> SignatureALG+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++doSign :: Alg pub priv -> priv -> B.ByteString -> IO B.ByteString+doSign (AlgRSA _ hash) key msg = do+ result <- RSA.signSafer (Just $ getHashAlgorithm hash) key msg+ case result of+ 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)+ Right sigBits -> return sigBits+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+ 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 $ convert $ Ed25519.sign key (Ed25519.toPublic 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.+--+-- 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+ , pairSignedCert :: SignedCertificate+ , pairKey :: priv+ }++-- | Builds a DN with a single component.+mkDn :: String -> DistinguishedName+mkDn cn = DistinguishedName [(getObjectID DnCommonName, fromString cn)]++-- | Used to build a certificate extension.+mkExtension :: Extension a => Bool -> a -> ExtensionRaw+mkExtension crit ext = ExtensionRaw (extOID ext) crit (extEncodeBs ext)++-- | Default extensions in leaf certificates.+leafStdExts :: [ExtensionRaw]+leafStdExts = [ku, eku]+ where+ ku = mkExtension False $ ExtKeyUsage+ [ KeyUsage_digitalSignature , KeyUsage_keyEncipherment ]+ eku = mkExtension False $ ExtExtendedKeyUsage+ [ KeyUsagePurpose_ServerAuth , KeyUsagePurpose_ClientAuth ]+++-- Authority signing a certificate --+--+-- When the certificate is self-signed, issuer and subject are the same. So+-- they have identical signature algorithms. The purpose of the GADT is to+-- hold this constraint only in the self-signed case.++-- | 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++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 _ 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 _ 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 version serial dn validity exts auth (algS, pubKey, privKey) = do+ signedCert <- objectToSignedExactF signatureFunction cert+ 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+ }++ signingKey = foldAuthPriv privKey pairKey auth+ algI = foldAuthPubPriv algS pairAlg auth++ signAlgI = getSignatureALG algI+ issuerDN = foldAuth dn (certSubjectDN . pairCert) auth+ extensions = Extensions (if null exts then Nothing else Just exts)++ signatureFunction objRaw = do+ sigBits <- doSign algI signingKey objRaw+ return (sigBits, signAlgI)++-- | 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 serial cn validity bc ku =+ 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 cn validity = mkCertificate 2 100 (mkDn cn) validity leafStdExts
+ Tests/Tests.hs view
@@ -0,0 +1,597 @@+-- | Validation test suite.+module Main (main) where++import Control.Applicative+import Control.Monad (unless)++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+ }+ curveName = ECC.SEC_p384r1
+ crypton-x509-validation.cabal view
@@ -0,0 +1,62 @@+Name: crypton-x509-validation+version: 1.6.12+Description: X.509 Certificate and CRL validation. please see README+License: BSD3+License-file: LICENSE+Copyright: Vincent Hanquez <vincent@snarc.org>+Author: Vincent Hanquez <vincent@snarc.org>+Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+Synopsis: X.509 Certificate and CRL validation+Build-Type: Simple+Category: Data+stability: experimental+Homepage: https://github.com/kazu-yamamoto/crypton-certificate+Cabal-Version: >= 1.10++Library+ Default-Language: Haskell2010+ Build-Depends: base >= 3 && < 5+ , bytestring+ , memory+ , mtl+ , containers+ , hourglass+ , data-default-class+ , pem >= 0.1+ , asn1-types >= 0.3 && < 0.4+ , asn1-encoding >= 0.9 && < 0.10+ , crypton-x509 >= 1.7.5+ , crypton-x509-store >= 1.6+ , crypton >= 0.24+ Exposed-modules: Data.X509.Validation+ Other-modules: Data.X509.Validation.Signature+ Data.X509.Validation.Fingerprint+ Data.X509.Validation.Cache+ Data.X509.Validation.Types+ ghc-options: -Wall++Test-Suite test-x509-validation+ Default-Language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: Tests+ Main-is: Tests.hs+ Other-modules: Certificate+ Build-Depends: base >= 3 && < 5+ , bytestring+ , memory+ , data-default-class+ , tasty+ , tasty-hunit+ , hourglass+ , asn1-types+ , asn1-encoding+ , crypton-x509 >= 1.7.1+ , crypton-x509-store+ , crypton-x509-validation+ , crypton+ ghc-options: -Wall++source-repository head+ type: git+ location: https://github.com/kazu-yamamoto/crypton-certificate+ subdir: x509-validation