x509-validation-1.6.9/Data/0000755000000000000000000000000013124231131013412 5ustar0000000000000000x509-validation-1.6.9/Data/X509/0000755000000000000000000000000013137710075014074 5ustar0000000000000000x509-validation-1.6.9/Data/X509/Validation/0000755000000000000000000000000013137710124016161 5ustar0000000000000000x509-validation-1.6.9/Tests/0000755000000000000000000000000013137710124013653 5ustar0000000000000000x509-validation-1.6.9/Data/X509/Validation.hs0000644000000000000000000004753413137710075016537 0ustar0000000000000000-- | -- 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 , 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 failedReasons <- doValidate 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 :: DateTime -> 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) 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) -- 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] | otherwise -> case findIssuer (certIssuerDN cert) chain of Nothing -> return [UnknownCA] Just (issuer, remaining) -> return (checkCA level $ getCertificate issuer) |> return (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, return ((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 :: 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 exhaustiveList :: Monad m => Bool -> [(Bool, m [FailedReason])] -> m [FailedReason] exhaustiveList _ [] = return [] exhaustiveList isExhaustive ((performCheck,c):cs) | performCheck = exhaustive isExhaustive c (exhaustiveList isExhaustive cs) | otherwise = exhaustiveList isExhaustive cs x509-validation-1.6.9/Data/X509/Validation/Signature.hs0000644000000000000000000001424213137710124020461 0ustar0000000000000000-- | -- 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 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 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) 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 x509-validation-1.6.9/Data/X509/Validation/Fingerprint.hs0000644000000000000000000000254213124231131020777 0ustar0000000000000000-- | -- Module : Data.X509.Validation.Fingerprint -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Data.X509.Validation.Fingerprint ( Fingerprint(..) , getFingerprint ) where import Crypto.Hash import Data.X509 import Data.ASN1.Types import Data.ByteArray (convert) 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 -- | 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 x509-validation-1.6.9/Data/X509/Validation/Cache.hs0000644000000000000000000001026613124231131017515 0ustar0000000000000000-- | -- 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) x509-validation-1.6.9/Data/X509/Validation/Types.hs0000644000000000000000000000155613124231131017620 0ustar0000000000000000-- | -- 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) x509-validation-1.6.9/Tests/Tests.hs0000644000000000000000000007714313124231131015315 0ustar0000000000000000-- | 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) ] 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-1.6.9/Tests/Certificate.hs0000644000000000000000000002532013137710124016433 0ustar0000000000000000{-# 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.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.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 -- | 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) 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 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 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 ] -- 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 x509-validation-1.6.9/LICENSE0000644000000000000000000000273113124231131013551 0ustar0000000000000000Copyright (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. x509-validation-1.6.9/Setup.hs0000644000000000000000000000005613124231131014176 0ustar0000000000000000import Distribution.Simple main = defaultMain x509-validation-1.6.9/x509-validation.cabal0000644000000000000000000000415713137710766016415 0ustar0000000000000000Name: x509-validation version: 1.6.9 Description: X.509 Certificate and CRL validation License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez Author: Vincent Hanquez Maintainer: Vincent Hanquez Synopsis: X.509 Certificate and CRL validation Build-Type: Simple Category: Data stability: experimental Homepage: http://github.com/vincenthz/hs-certificate Cabal-Version: >= 1.10 Library Default-Language: Haskell2010 Build-Depends: base >= 3 && < 5 , bytestring , memory , byteable , mtl , containers , hourglass , data-default-class , pem >= 0.1 && < 0.3 , asn1-types >= 0.3 && < 0.4 , asn1-encoding >= 0.9 && < 0.10 , x509 >= 1.6.5 , x509-store >= 1.6 , cryptonite >= 0.8 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 , 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 type: git location: git://github.com/vincenthz/hs-certificate subdir: x509-validation