diff --git a/Data/X509/Validation.hs b/Data/X509/Validation.hs new file mode 100644 --- /dev/null +++ b/Data/X509/Validation.hs @@ -0,0 +1,406 @@ +-- | +-- Module : Data.X509.Validation +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Data/X509/Validation/Cache.hs b/Data/X509/Validation/Cache.hs new file mode 100644 --- /dev/null +++ b/Data/X509/Validation/Cache.hs @@ -0,0 +1,98 @@ +-- | +-- Module : Data.X509.Validation.Cache +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) + diff --git a/Data/X509/Validation/Fingerprint.hs b/Data/X509/Validation/Fingerprint.hs new file mode 100644 --- /dev/null +++ b/Data/X509/Validation/Fingerprint.hs @@ -0,0 +1,38 @@ +-- | +-- Module : Data.X509.Validation.Fingerprint +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.X509.Validation.Fingerprint + ( Fingerprint(..) + , getFingerprint + ) where + +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 diff --git a/Data/X509/Validation/Signature.hs b/Data/X509/Validation/Signature.hs new file mode 100644 --- /dev/null +++ b/Data/X509/Validation/Signature.hs @@ -0,0 +1,163 @@ +-- | +-- Module : Data.X509.Validation.Signature +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Data/X509/Validation/Types.hs b/Data/X509/Validation/Types.hs new file mode 100644 --- /dev/null +++ b/Data/X509/Validation/Types.hs @@ -0,0 +1,29 @@ +-- | +-- Module : Data.X509.Validation.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010-2013 Vincent Hanquez + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Tests/Certificate.hs b/Tests/Certificate.hs new file mode 100644 --- /dev/null +++ b/Tests/Certificate.hs @@ -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 diff --git a/Tests/Tests.hs b/Tests/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests/Tests.hs @@ -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 diff --git a/crypton-x509-validation.cabal b/crypton-x509-validation.cabal new file mode 100644 --- /dev/null +++ b/crypton-x509-validation.cabal @@ -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 +Author: Vincent Hanquez +Maintainer: Kazu Yamamoto +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