x509-validation 1.5.0 → 1.6.12
raw patch · 7 files changed
Files
- Data/X509/Validation.hs +82/−60
- Data/X509/Validation/Fingerprint.hs +13/−20
- Data/X509/Validation/Signature.hs +83/−9
- Data/X509/Validation/Types.hs +2/−1
- Tests/Certificate.hs +321/−0
- Tests/Tests.hs +597/−0
- x509-validation.cabal +33/−17
Data/X509/Validation.hs view
@@ -23,27 +23,36 @@ , 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.Time.Clock+import Data.Hourglass+import System.Hourglass import Data.Maybe import Data.List --- | Possible reason of certificate and chain failure+-- | 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@@ -77,7 +86,7 @@ checkTimeValidity :: Bool -- | The time when the validity check happens. When set to Nothing, -- the current time will be used- , checkAtTime :: Maybe UTCTime+ , 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@@ -116,11 +125,13 @@ -- BEWARE, it's easy to change behavior leading to compromised security. data ValidationHooks = ValidationHooks {- -- | check the the issuer 'DistinguishedName' match the subject 'DistinguishedName'- -- of a certificate.+ -- | check whether a given issuer 'DistinguishedName' matches the subject+ -- 'DistinguishedName' of a candidate issuer certificate. hookMatchSubjectIssuer :: DistinguishedName -> Certificate -> Bool- -- | validate that the parametrized time valide with the certificate in argument- , hookValidateTime :: UTCTime -> 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@@ -190,44 +201,44 @@ ValidationCachePass -> return [] ValidationCacheDenied s -> return [CacheSaysNo s] ValidationCacheUnknown -> do- validationTime <- maybe getCurrentTime return $ checkAtTime checks- failedReasons <- doValidate validationTime hooks checks store ident cc+ 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 parameters-doValidate :: UTCTime- -> ValidationHooks- -> ValidationChecks- -> CertificateStore- -> ServiceID- -> CertificateChain- -> IO [FailedReason]-doValidate _ _ _ _ _ (CertificateChain []) = return [EmptyChain]-doValidate validationTime hooks checks store (fqhn,_) (CertificateChain (top:rchain)) =- (hookFilterReason hooks) <$> (return doLeafChecks |> doCheckChain 0 top rchain)+-- | 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] -> IO [FailedReason]- doCheckChain level current chain = do- r <- 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.- return r |> (case findCertificate (certIssuerDN cert) store of- Just trustedSignedCert -> return $ checkSignature current trustedSignedCert- Nothing | isSelfSigned cert -> return [SelfSigned] |> return (checkSignature current current)- | null chain -> return [UnknownCA]+ |> (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 -> return [UnknownCA]+ Nothing -> [UnknownCA] Just (issuer, remaining) ->- return (checkCA level $ getCertificate issuer)- |> return (checkSignature current issuer)+ 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.@@ -296,7 +307,7 @@ doCheckCertificate cert = exhaustiveList (checkExhaustive checks)- [ (checkTimeValidity checks, return ((hookValidateTime hooks) validationTime cert))+ [ (checkTimeValidity checks, hookValidateTime hooks validationTime cert) ] isSelfSigned :: Certificate -> Bool isSelfSigned cert = certSubjectDN cert == certIssuerDN cert@@ -308,7 +319,7 @@ SignatureFailed r -> [InvalidSignature r] -- | Validate that the current time is between validity bounds-validateTime :: UTCTime -> Certificate -> [FailedReason]+validateTime :: DateTime -> Certificate -> [FailedReason] validateTime currentTime cert | currentTime < before = [InFuture] | currentTime > after = [Expired]@@ -324,13 +335,21 @@ unAltName _ = Nothing -- | Validate that the fqhn is matched by at least one name in the certificate.--- The name can be either the common name or one of the alternative names if--- the SubjectAltName extension is present.+-- 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 =- case commonName of- Nothing -> [NoCommonName]- Just cn -> findMatch [] $ map (matchDomain . splitDot) (cn : altNames)+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]@@ -338,31 +357,35 @@ findMatch _ ([]:_) = [] findMatch acc (_ :xs) = findMatch acc xs - matchDomain :: [String] -> [FailedReason]- matchDomain l- | length (filter (== "") l) > 0 = [InvalidName (intercalate "." l)]- | head l == "*" = wildcardMatch (reverse $ drop 1 l)- | l == splitDot fqhn = [] -- 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] - -- only 1 wildcard is valid, and if multiples are present+ -- 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- -- <star>.com or <star> is always invalid- | length l < 2 = [InvalidWildcard]- -- some TLD like .uk got small subTLS like (.co.uk), and we don't want to accept *.co.uk- | length (head l) <= 2 && length (head $ drop 1 l) <= 3 && length l < 3 = [InvalidWildcard]- | l == take (length l) (reverse $ splitDot fqhn) = [] -- success: we got a match- | otherwise = [NameMismatch fqhn]+ | 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- y : (if z == "" then [] else splitDot $ drop 1 z)+ map toLower y : (if z == "" then [] else splitDot $ drop 1 z) -- | return true if the 'subject' certificate's issuer match@@ -370,15 +393,14 @@ matchSI :: DistinguishedName -> Certificate -> Bool matchSI issuerDN issuer = certSubjectDN issuer == issuerDN -exhaustive :: Monad m => Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]-exhaustive isExhaustive f1 f2 = f1 >>= cont- where cont l1- | null l1 = f2- | isExhaustive = f2 >>= \l2 -> return (l1 ++ l2)- | otherwise = return l1+exhaustive :: Bool -> [FailedReason] -> [FailedReason] -> [FailedReason]+exhaustive isExhaustive l1 l2+ | null l1 = l2+ | isExhaustive = l1 ++ l2+ | otherwise = l1 -exhaustiveList :: Monad m => Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]-exhaustiveList _ [] = return []+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/Fingerprint.hs view
@@ -5,24 +5,21 @@ -- Stability : experimental -- Portability : unknown --+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.X509.Validation.Fingerprint ( Fingerprint(..) , getFingerprint- , toDescr ) where -import Crypto.PubKey.HashDescr+import Crypto.Hash import Data.X509 import Data.ASN1.Types+import Data.ByteArray (convert, ByteArrayAccess) import Data.ByteString (ByteString)-import Data.Byteable -- | Fingerprint of a certificate newtype Fingerprint = Fingerprint ByteString- deriving (Show,Eq)--instance Byteable Fingerprint where- toBytes (Fingerprint bs) = bs+ deriving (Show,Eq,ByteArrayAccess) -- | Get the fingerprint of the whole signed object -- using the hashing algorithm specified@@ -30,16 +27,12 @@ => SignedExact a -- ^ object to fingerprint -> HashALG -- ^ algorithm to compute the fingerprint -> Fingerprint -- ^ fingerprint in binary form-getFingerprint sobj halg = Fingerprint $ hashF $ encodeSignedObject sobj- where hashDescr = toDescr halg- hashF = hashFunction hashDescr---- | Convert a hash algorithm into a Hash Description-toDescr :: HashALG -> HashDescr-toDescr HashMD2 = hashDescrMD2-toDescr HashMD5 = hashDescrMD5-toDescr HashSHA1 = hashDescrSHA1-toDescr HashSHA224 = hashDescrSHA224-toDescr HashSHA256 = hashDescrSHA256-toDescr HashSHA384 = hashDescrSHA384-toDescr HashSHA512 = hashDescrSHA512+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
@@ -14,13 +14,19 @@ , 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.Hash.SHA1 as SHA1+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.Validation.Fingerprint+import Data.X509.EC import Data.ASN1.Types import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding@@ -64,6 +70,19 @@ -> 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@@ -72,18 +91,73 @@ else SignatureFailed SignatureInvalid | otherwise = SignatureFailed SignaturePubkeyMismatch where- verifyF (PubKeyRSA key) = Just $ RSA.verify (toDescr hashALG) key+ verifyF (PubKeyRSA key) = Just $ rsaVerify hashALG key verifyF (PubKeyDSA key)- | hashALG == HashSHA1 = Just $ \a b -> case dsaToSignature a of- Nothing -> False- Just dsaSig -> DSA.verify SHA1.hash key dsaSig b+ | 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 fromASN1 asn1 of- Left _ -> Nothing- Right (dsaSig, _) -> Just dsaSig+ 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
@@ -11,8 +11,9 @@ , HostName ) where -import Network.BSD (HostName) import Data.ByteString (ByteString)++type HostName = String -- | identification of the connection consisting of the -- fully qualified host name (e.g. www.example.com) and
+ 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
x509-validation.cabal view
@@ -1,6 +1,6 @@ Name: x509-validation-Version: 1.5.0-Description: X.509 Certificate and CRL 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>@@ -11,33 +11,49 @@ Category: Data stability: experimental Homepage: http://github.com/vincenthz/hs-certificate-Cabal-Version: >=1.6+Cabal-Version: >= 1.10 Library+ Default-Language: Haskell2010 Build-Depends: base >= 3 && < 5 , bytestring- , byteable- , network+ , memory , mtl , containers- , directory- , filepath- , process- , time+ , hourglass , data-default-class- , pem >= 0.1 && < 0.3- , asn1-types >= 0.2 && < 0.3- , asn1-encoding >= 0.8 && < 0.9- , x509 >= 1.4.7 && < 1.5- , x509-store >= 1.4 && < 1.5- , crypto-pubkey >= 0.1.4 && < 0.3- , crypto-pubkey-types >= 0.4 && < 0.5- , cryptohash >= 0.9 && < 0.12+ , pem >= 0.1+ , asn1-types >= 0.3 && < 0.4+ , asn1-encoding >= 0.9 && < 0.10+ , x509 >= 1.7.5+ , x509-store >= 1.6+ , cryptonite >= 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+ , x509 >= 1.7.1+ , x509-store+ , x509-validation+ , cryptonite ghc-options: -Wall source-repository head