crypton-x509-validation 1.10.0 → 1.10.1
raw patch · 6 files changed
+812/−108 lines, 6 filesdep ~crypton-x509PVP ok
version bump matches the API change (PVP)
Dependency ranges changed: crypton-x509
API changes (from Hackage documentation)
+ Data.X509.Validation: instance GHC.Classes.Eq Data.X509.Validation.NameMatch
Files
- ChangeLog.md +13/−0
- Data/X509/Validation.hs +233/−102
- Data/X509/Validation/Internal.hs +43/−0
- Data/X509/Validation/Signature.hs +32/−4
- Tests/Tests.hs +488/−0
- crypton-x509-validation.cabal +3/−2
ChangeLog.md view
@@ -1,5 +1,18 @@ # ChangeLog for crypton-x509-validation +## 1.10.1++* Fix name constraint bypasses: constraints are accumulated per RFC+ 5280, apply to the leaf even if self-issued and to the CN used as a+ host name, dNSName matching is case-insensitive, and iPAddress,+ rfc822Name, URI and directoryName constraints are enforced.+* Undecodable NameConstraints, BasicConstraints, KeyUsage,+ ExtendedKeyUsage and SubjectAltName extensions fail validation+ instead of being ignored.+* Reject degenerate DSA parameters and oversized RSA keys before+ verifying signatures.+* Limit the chain depth to 20 CA certificates.+ ## 1.10.0 * Verify ML-DSA signatures
Data/X509/Validation.hs view
@@ -41,11 +41,12 @@ import Control.Monad (when) import Data.ASN1.Types import Data.Bits-import Data.ByteString (unpack)+import Data.ByteString (ByteString, unpack)+import qualified Data.ByteString as B import Data.Char (toLower) import Data.Default import Data.Hourglass-import Data.IP (IPv4, IPv6, toIPv4, toIPv6)+import Data.IP (IPv4, IPv6, fromIPv4, fromIPv6b, toIPv4, toIPv6) import Data.List import Data.Maybe import Data.Word (Word8)@@ -53,6 +54,7 @@ import Data.X509.CertificateStore import Data.X509.Validation.Cache import Data.X509.Validation.Fingerprint+import Data.X509.Validation.Internal (safeCharacterToString) import Data.X509.Validation.Signature import Data.X509.Validation.Types import Text.Read (readMaybe)@@ -292,7 +294,13 @@ doCheckChain :: Int -> SignedCertificate -> [SignedCertificate] -> [FailedReason]- doCheckChain level current chain =+ doCheckChain level current chain+ | level > maxChainDepth = [AuthorityTooDeep]+ | otherwise = doCheckChain' level current chain++ 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@@ -325,8 +333,9 @@ | matchSubjectIdentifier issuerDN (getCertificate c) -> Just (c, cs) | otherwise -> Nothing | otherwise =- (\x -> (x, filter (/= x) chain))- `fmap` find (matchSubjectIdentifier issuerDN . getCertificate) chain+ case break (matchSubjectIdentifier issuerDN . getCertificate) chain of+ (before, x : after) -> Just (x, before ++ after)+ _ -> Nothing matchSubjectIdentifier :: DistinguishedName -> Certificate -> Bool matchSubjectIdentifier = hookMatchSubjectIssuer hooks @@ -345,11 +354,13 @@ ++ (if allowedDepth then [] else [AuthorityTooDeep]) where extensions = certExtensions cert- allowedSign = case extensionGet extensions of- Just (ExtKeyUsage flags) -> KeyUsage_keyCertSign `elem` flags+ -- an extension that cannot be decoded is not treated as absent+ allowedSign = case extensionGetE extensions of+ Just (Right (ExtKeyUsage flags)) -> KeyUsage_keyCertSign `elem` flags+ Just (Left _) -> False Nothing -> True- (allowedCA, pathLen) = case extensionGet extensions of- Just (ExtBasicConstraints True pl) -> (True, pl)+ (allowedCA, pathLen) = case extensionGetE extensions of+ Just (Right (ExtBasicConstraints True pl)) -> (True, pl) _ -> (False, Nothing) allowedDepth = case pathLen of Nothing -> True@@ -380,17 +391,20 @@ (checkLeafKeyPurpose checks) LeafKeyPurposeNotAllowed where- mflags = case extensionGet $ certExtensions cert of- Just (ExtKeyUsage keyflags) -> Just keyflags+ mflags = case extensionGetE $ certExtensions cert of+ Just (Right (ExtKeyUsage keyflags)) -> Just (Right keyflags)+ Just (Left e) -> Just (Left e) Nothing -> Nothing- mpurposes = case extensionGet $ certExtensions cert of- Just (ExtExtendedKeyUsage keyPurposes) -> Just keyPurposes+ mpurposes = case extensionGetE $ certExtensions cert of+ Just (Right (ExtExtendedKeyUsage keyPurposes)) -> Just (Right keyPurposes)+ Just (Left e) -> Just (Left e) 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]+ -- return [err]. An undecodable extension always fails. compareListIfExistAndNotNull Nothing _ _ = []- compareListIfExistAndNotNull (Just list) expected err+ compareListIfExistAndNotNull (Just (Left _)) _ err = [err]+ compareListIfExistAndNotNull (Just (Right list)) expected err | null expected = [] | intersect expected list == expected = [] | otherwise = [err]@@ -410,49 +424,74 @@ SignaturePass -> [] SignatureFailed r -> [InvalidSignature r] + -- Failures to build the chain are reported by 'doCheckChain'. doCheckNameConst :: SignedCertificate -> [SignedCertificate] -> [FailedReason]- doCheckNameConst current0 chain0 = case loop current0 chain0 [] of+ doCheckNameConst current0 chain0 = case loop (0 :: Int) current0 chain0 [] of Left errs -> errs Right ts -> checkNameConstraints ts where- loop current chain acc = case findCertificate issuer store of- Just anchor -> Right $ getNameConstSpec (getCertificate anchor) True : spec : acc- Nothing- | null chain -> Left [] -- to pass the test- | otherwise -> case findIssuer issuer chain of- Nothing -> Left [] -- to pass the test- Just (issuer', remaining) -> loop issuer' remaining (spec : acc)+ loop level current chain acc+ | level > maxChainDepth = Left []+ | otherwise = case findCertificate issuer store of+ Just anchor -> Right $ getNameConstSpec (getCertificate anchor) False : spec : acc+ Nothing+ | null chain -> Left []+ | otherwise -> case findIssuer issuer chain of+ Nothing -> Left []+ Just (issuer', remaining) -> loop (level + 1) issuer' remaining (spec : acc) where cert = getCertificate current issuer = certIssuerDN cert- spec = getNameConstSpec cert (current0 /= current)+ isLeaf = level == 0+ spec = getNameConstSpec cert (isLeaf && checkFQHN checks) isSelfSigned :: Certificate -> Bool isSelfSigned cert = certSubjectDN cert == certIssuerDN cert +-- | The maximum number of CA certificates followed from the leaf.+maxChainDepth :: Int+maxChainDepth = 20+ data NameConstSpec = NameConstSpec- { ncSANs :: [AltName]- , ncExt :: Maybe ExtNameConstraints- , ncSelfSigned :: Bool- , ncCA :: Bool+ { ncNames :: Either String [AltName]+ -- ^ names subject to name constraints+ , ncExt :: Either String (Maybe ExtNameConstraints)+ , ncSelfIssued :: Bool } +-- | The second argument tells whether the CN is used as a host name. getNameConstSpec :: Certificate -> Bool -> NameConstSpec-getNameConstSpec cert ca =+getNameConstSpec cert useCN = NameConstSpec- { ncSANs = sans- , ncExt = extensionGet exts- , ncSelfSigned = isSelfSigned cert- , ncCA = ca+ { ncNames = names+ , ncExt = maybe (Right Nothing) (fmap Just) $ extensionGetE exts+ , ncSelfIssued = isSelfSigned cert } where exts = certExtensions cert- subj = AltNameDN $ certSubjectDN cert- sans :: [AltName]- sans = case extensionGet exts of- Nothing -> [subj]- Just (ExtSubjectAltName alts) -> subj : alts+ subjDN = certSubjectDN cert+ subj = [AltNameDN subjDN | not (null (getDistinguishedElements subjDN))]+ -- RFC 5280: without SAN, emailAddress in the subject is an rfc822Name+ emails =+ [ AltNameRFC822 e+ | (oid, v) <- getDistinguishedElements subjDN+ , oid == [1, 2, 840, 113549, 1, 9, 1]+ , Just e <- [safeCharacterToString v]+ ]+ cn+ | useCN = case getNames cert of+ Right (Just name, []) -> [maybe (AltNameDNS name) ipToAltName (parseIPAddress name)]+ _ -> []+ | otherwise = []+ names = case extensionGetE exts of+ Nothing -> Right (subj ++ emails ++ cn)+ Just (Right (ExtSubjectAltName alts)) -> Right (subj ++ alts ++ cn)+ Just (Left e) -> Left e +ipToAltName :: IPAddress -> AltName+ipToAltName (IPv4Address ip) = AltNameIP $ B.pack $ map fromIntegral $ fromIPv4 ip+ipToAltName (IPv6Address ip) = AltNameIP $ B.pack $ map fromIntegral $ fromIPv6b ip+ -- | Validate that the current time is between validity bounds validateTime :: DateTime -> Certificate -> [FailedReason] validateTime currentTime cert@@ -462,11 +501,14 @@ where (before, after) = certValidity cert -getNames :: Certificate -> (Maybe String, [String])-getNames cert = (commonName >>= asn1CharacterToString, altNames)+-- | 'Left' if the SAN extension is present but cannot be decoded.+getNames :: Certificate -> Either String (Maybe String, [String])+getNames cert = case extensionGetE $ certExtensions cert of+ Just (Left e) -> Left e+ Just (Right san) -> Right (commonName, toAltName san)+ Nothing -> Right (commonName, []) where- commonName = getDnElement DnCommonName $ certSubjectDN cert- altNames = maybe [] toAltName $ extensionGet $ certExtensions cert+ commonName = getDnElement DnCommonName (certSubjectDN cert) >>= safeCharacterToString toAltName (ExtSubjectAltName names) = catMaybes $ map unAltName names where unAltName (AltNameDNS s) = Just s@@ -514,11 +556,19 @@ -- subjectAltName are considered. Otherwise, the commonName from the subjectDN -- is used. --+-- If the subjectAltName extension cannot be decoded, the name never matches.+-- -- 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+validateCertificateName fqhn cert = case getNames cert of+ Left _ -> [NameMismatch fqhn]+ Right names -> validateNames fqhn cert names++validateNames+ :: HostName -> Certificate -> (Maybe String, [String]) -> [FailedReason]+validateNames fqhn cert (commonName, altNames) | not $ null altNames = case parseIPAddress fqhn of Nothing -> findMatch [] $ map matchDomain altNames@@ -531,8 +581,6 @@ Nothing -> [NoCommonName] Just cn -> findMatch [] $ [matchDomain cn] where- (commonName, altNames) = getNames cert- findMatch :: [FailedReason] -> [[FailedReason]] -> [FailedReason] findMatch _ [] = [NameMismatch fqhn] findMatch _ ([] : _) = []@@ -586,81 +634,164 @@ | performCheck = exhaustive isExhaustive c (exhaustiveList isExhaustive cs) | otherwise = exhaustiveList isExhaustive cs +-- | Name constraints accumulated along the chain (RFC 5280 6.1):+-- a name must be in a permitted subtree of every level that has one+-- and must not be in any excluded subtree.+data NameConstState = NameConstState [[GeneralSubtree]] [GeneralSubtree]++-- | The first element is the trust anchor and the last is the leaf. checkNameConstraints :: [NameConstSpec] -> [FailedReason]-checkNameConstraints xs0 = loop xs0+checkNameConstraints [] = []+checkNameConstraints (anchor : specs0) =+ either id (\st -> loop st specs0) $ addNameConst (NameConstState [] []) anchor where- loop [] = []- loop [_] = []- loop [a, b] = check a b- loop (a : b : cs) =- check a b ++ case nextNameConstSpec a b of- Left errs -> errs- Right b' -> loop (b' : cs)-- check ncs0 ncs1- | ncSelfSigned ncs1 = []- | otherwise = case ncExt ncs0 of- Nothing -> []- Just nc0 -> validateNamesInSubtrees (ncSANs ncs1) nc0--nextNameConstSpec- :: NameConstSpec- -> NameConstSpec- -> Either [FailedReason] NameConstSpec-nextNameConstSpec ncs0 ncs1- | not (ncCA ncs1) = Right ncs1- | otherwise = case stricter (ncExt ncs0) (ncExt ncs1) of- Left errs -> Left errs- Right mNC -> Right $ ncs1{ncExt = mNC}--stricter- :: Maybe ExtNameConstraints -- issuer: should be looser- -> Maybe ExtNameConstraints -- should be stricter- -> Either [FailedReason] (Maybe ExtNameConstraints)-stricter Nothing mnc = Right mnc-stricter (Just x) Nothing = Left [InvalidName $ show x]-stricter- (Just (ExtNameConstraints permitted0 excluded0))- (Just (ExtNameConstraints permitted1 excluded1))- | null errs =- Right $ Just $ ExtNameConstraints permitted1 (excluded1 ++ excluded0)- | otherwise = Left errs+ loop _ [] = []+ loop st (spec : specs) =+ check ++ case specs of+ [] -> []+ _ -> either id (\st' -> loop st' specs) $ addNameConst st spec where- errs = strictCheck permitted0 permitted1+ -- self-issued intermediates are exempt but the leaf is not+ check+ | ncSelfIssued spec && not (null specs) = []+ | otherwise = validateNames' st (ncNames spec) -strictCheck :: [GeneralSubtree] -> [GeneralSubtree] -> [FailedReason]-strictCheck permitted0 permitted1 = concatMap f permitted1- where- f (GeneralSubtree a _ _)- | any (\g -> (a `isIncludedIn` g) == Just True) permitted0 = []- | otherwise = [InvalidName $ show a]+addNameConst+ :: NameConstState -> NameConstSpec -> Either [FailedReason] NameConstState+addNameConst st@(NameConstState permitted excluded) spec = case ncExt spec of+ Left e -> Left [InvalidName $ "NameConstraints: " ++ e]+ Right Nothing -> Right st+ Right (Just (ExtNameConstraints p e)) ->+ Right $ NameConstState ([p | not (null p)] ++ permitted) (e ++ excluded) -validateNamesInSubtrees :: [AltName] -> ExtNameConstraints -> [FailedReason]-validateNamesInSubtrees altNames (ExtNameConstraints permitted excluded) =+validateNames' :: NameConstState -> Either String [AltName] -> [FailedReason]+validateNames' (NameConstState [] []) _ = []+validateNames' _ (Left e) = [InvalidName $ "SubjectAltName: " ++ e]+validateNames' (NameConstState permitted excluded) (Right altNames) = concatMap inc altNames ++ concatMap exc altNames where inc a- | nsMatch a permitted = []+ | all (nsMatch a) permitted = [] | otherwise = [InvalidName $ show a] exc a | nsNotMatch a excluded = [] | otherwise = [InvalidName $ show a] +data NameMatch = NotApplicable | Matched | NotMatched | Unsupported+ deriving (Eq)++-- | A permitted subtree list is satisfied if the name is in one of them+-- or if none of them is of the same type as the name. nsMatch :: AltName -> [GeneralSubtree] -> Bool-nsMatch a gs = any (== Just True) rs || all isNothing rs+nsMatch a gs = any (== Matched) rs || all (== NotApplicable) rs where- rs = map (a `isIncludedIn`) gs+ rs = map (matchSubtree False a) gs nsNotMatch :: AltName -> [GeneralSubtree] -> Bool-nsNotMatch a gs = all (\g -> (a `isIncludedIn` g) /= Just True) gs+nsNotMatch a = all ((`elem` [NotApplicable, NotMatched]) . matchSubtree True a) -isIncludedIn :: AltName -> GeneralSubtree -> Maybe Bool-isIncludedIn (AltNameDN nm0) (GeneralSubtree (AltNameDN nm1) _ _) = Just (nm0 == nm1)-isIncludedIn (AltNameDNS nm0) (GeneralSubtree (AltNameDNS nm1) _ _) = Just (nm0 == nm1 || ('.' : nm1) `isSuffixOf` nm0)--- isIncludedIn (AltNameRFC822 _) (GeneralSubtree (AltNameRFC822 _) _ _)= undefined--- isIncludedIn (AltNameURI _) (GeneralSubtree (AltNameURI _) _ _)= undefined--- isIncludedIn (AltNameIP _) (GeneralSubtree (AltNameIP _) _ _)= undefined-isIncludedIn _ _ = Nothing+-- | The first argument tells whether the subtree is an excluded one.+-- Unsupported forms count as matched when excluded and as not matched+-- when permitted.+matchSubtree :: Bool -> AltName -> GeneralSubtree -> NameMatch+matchSubtree isExcluded name (GeneralSubtree base _ _) = case (name, base) of+ (AltNameDNS n, AltNameDNS c) ->+ toMatch $ dnsInSubtree n c || (isExcluded && wildcardCovers n c)+ (AltNameDN n, AltNameDN c) -> toMatch $ dnInSubtree n c+ (AltNameIP n, AltNameIP c) -> ipInSubtree n c+ (AltNameRFC822 n, AltNameRFC822 c) -> maybe Unsupported toMatch $ emailInSubtree n c+ (AltNameURI n, AltNameURI c) -> maybe Unsupported (toMatch . (`hostInSubtree` c)) $ uriHost n+ (AltNameXMPP _, AltNameXMPP _) -> Unsupported+ (AltNameDNSSRV _, AltNameDNSSRV _) -> Unsupported+ _ -> NotApplicable+ where+ toMatch b = if b then Matched else NotMatched++-- | "example.com" covers itself and its subdomains, ".example.com" only+-- its subdomains. Compared case-insensitively.+dnsInSubtree :: String -> String -> Bool+dnsInSubtree n c+ | null c' = True+ | "." `isPrefixOf` c' = c' `isSuffixOf` n'+ | otherwise = n' == c' || ('.' : c') `isSuffixOf` n'+ where+ n' = map toLower n+ c' = map toLower c++-- | Whether a wildcard name such as "*.example.com" may stand for a name+-- in the subtree, e.g. "www.example.com".+wildcardCovers :: String -> String -> Bool+wildcardCovers n c = case stripPrefix "*." (map toLower n) of+ Just rest ->+ let c' = map toLower c+ label = take (length c' - length rest - 1) c'+ in not (null label)+ && '.' `notElem` label+ && ('.' : rest) `isSuffixOf` c'+ Nothing -> False++hostInSubtree :: String -> String -> Bool+hostInSubtree h c+ | "." `isPrefixOf` c' = c' `isSuffixOf` h'+ | otherwise = h' == c'+ where+ h' = map toLower h+ c' = map toLower c++-- | "user@host" matches exactly, "host" matches all mailboxes on the host+-- and ".example.com" all mailboxes on its subdomains.+emailInSubtree :: String -> String -> Maybe Bool+emailInSubtree n c = case breakAt n of+ Just (local, host) -> Just $ case breakAt c of+ Just (cLocal, cHost) -> local == cLocal && map toLower host == map toLower cHost+ Nothing -> hostInSubtree host c+ Nothing -> Nothing+ where+ breakAt x = case break (== '@') (reverse x) of+ (rhost, '@' : rlocal) -> Just (reverse rlocal, reverse rhost)+ _ -> Nothing++-- | The host of a URI with an authority; 'Nothing' for IP literals.+uriHost :: String -> Maybe String+uriHost uri = case break (== ':') uri of+ (_, ':' : '/' : '/' : rest) ->+ let authority = takeWhile (`notElem` ("/?#" :: String)) rest+ hostport = reverse $ takeWhile (/= '@') $ reverse authority+ host = takeWhile (/= ':') hostport+ in if null host || "[" `isPrefixOf` hostport || isJust (parseIPAddress host)+ then Nothing+ else Just host+ _ -> Nothing++-- | The subtree is a prefix of the name. Attribute values are compared+-- case-insensitively with whitespace folded.+dnInSubtree :: DistinguishedName -> DistinguishedName -> Bool+dnInSubtree (DistinguishedName n) (DistinguishedName c) =+ length c <= length n && and (zipWith eq n c)+ where+ eq (o1, v1) (o2, v2) = o1 == o2 && norm v1 == norm v2+ norm v = case safeCharacterToString v of+ Just str -> Right $ unwords $ words $ map toLower str+ Nothing -> Left v++-- | An IPv4 or IPv6 address against an address with a mask.+ipInSubtree :: ByteString -> ByteString -> NameMatch+ipInSubtree n c+ | B.length c /= 8 && B.length c /= 32 = Unsupported+ | B.length n /= 4 && B.length n /= 16 = Unsupported+ | 2 * B.length n /= B.length c = NotMatched+ | otherwise =+ if and+ ( zipWith3+ (\x a m -> x .&. m == a .&. m)+ (B.unpack n)+ (B.unpack addr)+ (B.unpack mask)+ )+ then Matched+ else NotMatched+ where+ (addr, mask) = B.splitAt (B.length n) c doCriticalExtensionSweep :: Certificate -> [FailedReason] doCriticalExtensionSweep cert = case mexts of
+ Data/X509/Validation/Internal.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module : Data.X509.Validation.Internal+-- License : BSD-style+-- Stability : experimental+-- Portability : unknown+--+-- Guards against exceptions thrown from pure code on malformed input.+module Data.X509.Validation.Internal (+ tryPure,+ safeCharacterToString,+) where++import Control.Exception (+ SomeAsyncException,+ SomeException,+ evaluate,+ fromException,+ throwIO,+ try,+ )+import Data.ASN1.Types (ASN1CharacterString, asn1CharacterToString)+import qualified Data.List as L+import System.IO.Unsafe (unsafeDupablePerformIO)++-- | Run a forcing function and turn synchronous exceptions into 'Left'.+tryPure :: (a -> ()) -> a -> Either String a+tryPure force x = unsafeDupablePerformIO $ do+ res <- try $ evaluate $ force x+ case res of+ Right () -> return $ Right x+ Left (e :: SomeException)+ | Just (_ :: SomeAsyncException) <- fromException e -> throwIO e+ | otherwise -> return $ Left (show e)+{-# NOINLINE tryPure #-}++-- | Like 'asn1CharacterToString' but 'Nothing' on invalid encoding.+safeCharacterToString :: ASN1CharacterString -> Maybe String+safeCharacterToString cs =+ asn1CharacterToString cs >>= either (const Nothing) Just . tryPure force+ where+ force = L.foldl' (flip seq) ()
Data/X509/Validation/Signature.hs view
@@ -15,12 +15,14 @@ import Crypto.Error (CryptoFailable (..)) import Crypto.Hash+import Crypto.Number.Basic (numBits) import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Types as ECC import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.MLDSA as MLDSA+import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS @@ -30,6 +32,7 @@ import Data.ByteString (ByteString) import Data.X509 import Data.X509.EC+import Data.X509.Validation.Internal (tryPure) -- | A set of possible return from signature verification. --@@ -81,8 +84,33 @@ -> ByteString -- ^ Signature to verify -> SignatureVerification-verifySignature (SignatureALG_Unknown _) _ _ _ = SignatureFailed SignatureUnimplemented-verifySignature (SignatureALG hashALG PubKeyALG_RSAPSS) pubkey cdata signature = case verifyF pubkey of+verifySignature alg pubkey cdata signature+ | not (acceptablePubKey pubkey) = SignatureFailed SignatureInvalid+ | otherwise =+ -- degenerate keys or encodings must not throw from pure code+ either (const $ SignatureFailed SignatureInvalid) id $+ tryPure (`seq` ()) (verifySignature' alg pubkey cdata signature)++-- | Reject key parameters that are invalid or too costly to verify with.+acceptablePubKey :: PubKey -> Bool+acceptablePubKey (PubKeyRSA (RSA.PublicKey _ n e)) =+ n > 1 && numBits n <= 16384 && e > 1 && numBits e <= 64+acceptablePubKey (PubKeyDSA (DSA.PublicKey (DSA.Params p g q) y)) =+ p > 2+ && numBits p <= 8192+ && q > 1+ && q < p+ && numBits q <= 512+ && g > 1+ && g < p+ && y > 1+ && y < p+acceptablePubKey _ = True++verifySignature'+ :: SignatureALG -> PubKey -> ByteString -> ByteString -> 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@@ -96,7 +124,7 @@ | hashALG == HashSHA224 = Just $ PSS.verify (PSS.defaultPSSParams SHA224) key | otherwise = Nothing verifyF _ = Nothing-verifySignature (SignatureALG hashALG pubkeyALG) pubkey cdata signature+verifySignature' (SignatureALG hashALG pubkeyALG) pubkey cdata signature | pubkeyToAlg pubkey == pubkeyALG = case verifyF pubkey of Nothing -> SignatureFailed SignatureUnimplemented Just f ->@@ -137,7 +165,7 @@ 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+verifySignature' (SignatureALG_IntrinsicHash pubkeyALG) pubkey cdata signature | pubkeyToAlg pubkey == pubkeyALG = doVerify pubkey | otherwise = SignatureFailed SignaturePubkeyMismatch where
Tests/Tests.hs view
@@ -7,8 +7,14 @@ import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.Types as ECC+import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PSS as PSS +import Data.ASN1.BinaryEncoding (DER (..))+import Data.ASN1.BitArray (toBitArray)+import Data.ASN1.Encoding (encodeASN1')+import Data.ASN1.Types+ import Data.Default import Data.Monoid import Data.String (fromString)@@ -620,6 +626,487 @@ caseName = if null hostname then "empty" else hostname checks = defaultChecks{checkExhaustive = True} +-- | Validates a chain against a store and checks only success or failure.+assertPassOrFail+ :: CertificateStore+ -> ValidationChecks+ -> HostName+ -> [Pair pub priv]+ -> Bool+ -> Assertion+assertPassOrFail store checks hostname ps pass = do+ actual <- validate HashSHA256 defaultHooks checks store def ident chain+ unless (null actual == pass) $+ assertFailure $+ (if pass then "expected success but got: " else "expected failure but got: ")+ ++ show actual+ where+ ident = (hostname, fromString ":443")+ chain = CertificateChain (map pairSignedCert ps)++nameConstraints :: [AltName] -> [AltName] -> ExtensionRaw+nameConstraints p e = mkExtension True $ ExtNameConstraints (map sub p) (map sub e)+ where+ sub a = GeneralSubtree a 0 Nothing++caBC :: ExtensionRaw+caBC = mkExtension True $ ExtBasicConstraints True Nothing++sanExt :: [AltName] -> ExtensionRaw+sanExt = mkExtension False . ExtSubjectAltName++-- | Tests name constraints of an intermediate CA and an optional sub-CA+-- against a leaf certificate.+testNameConstraints+ :: IO (RData pub priv)+ -> TestName+ -> [ExtensionRaw]+ -- ^ Extensions of the CA in addition to basic constraints+ -> Maybe [ExtensionRaw]+ -- ^ Extensions of the sub-CA, if any+ -> DistinguishedName+ -- ^ Leaf subject+ -> [ExtensionRaw]+ -- ^ Leaf extensions+ -> HostName+ -> Bool+ -- ^ Expected success+ -> TestTree+testNameConstraints res caseName caExts msubExts leafDN leafExts hostname pass =+ testWithRes res caseName $ \rd -> do+ ca <-+ mkCertificate+ 2+ 30+ (mkDn "NC CA")+ (present rd)+ (caBC : caExts)+ (CA $ root rd)+ (keys1 rd)+ (issuer, chain) <- case msubExts of+ Nothing -> return (ca, [ca])+ Just subExts -> do+ sub <-+ mkCertificate+ 2+ 31+ (mkDn "NC Sub CA")+ (present rd)+ (caBC : subExts)+ (CA ca)+ (keys2 rd)+ return (sub, [sub, ca])+ leaf <- mkCertificate 2 100 leafDN (present rd) leafExts (CA issuer) (keys3 rd)+ assertPassOrFail (rootStore rd) defaultChecks hostname (leaf : chain) pass++-- | A leaf whose subject equals the issuer is not exempt from the name+-- constraints of a trust anchor.+testSelfIssuedLeaf :: IO (RData pub priv) -> TestName -> TestTree+testSelfIssuedLeaf res caseName = testWithRes res caseName $ \rd -> do+ let exts = [caBC, nameConstraints [AltNameDNS "example.com"] []]+ anchor <- mkCertificate 2 40 (mkDn "NC Root") (present rd) exts Self (keys1 rd)+ leaf <-+ mkCertificate+ 2+ 41+ (mkDn "NC Root")+ (present rd)+ [sanExt [AltNameDNS "www.google.com"]]+ (CA anchor)+ (keys2 rd)+ assertPassOrFail (mkStore [anchor]) defaultChecks "www.google.com" [leaf] False++-- | Tests a chain longer than the supported depth.+testLongChain :: IO (RData pub priv) -> TestName -> Int -> Bool -> TestTree+testLongChain res caseName len pass = testWithRes res caseName $ \rd -> do+ let mk issuer i =+ mkCertificate+ 2+ (fromIntegral i)+ (mkDn ("CA" ++ show i))+ (present rd)+ [caBC]+ (CA issuer)+ (keys1 rd)+ go issuer i acc+ | i > len = return (issuer, acc)+ | otherwise = mk issuer i >>= \c -> go c (i + 1) (c : acc)+ (lastCA, cas) <- go (root rd) (1 :: Int) []+ leaf <- mkLeaf "long-chain" (present rd) (CA lastCA) (keys2 rd)+ assertPassOrFail (rootStore rd) defaultChecks "long-chain" (leaf : cas) pass++-- | Tests a CA or leaf with an extension that cannot be decoded.+testMalformedExt+ :: IO (RData pub priv)+ -> TestName+ -> Bool+ -> ExtensionRaw+ -> ValidationChecks+ -> [FailedReason]+ -> TestTree+testMalformedExt res caseName onCA ext checks expected = testWithRes res caseName $ \rd -> do+ ca <-+ mkCertificate+ 2+ 50+ (mkDn "Malformed CA")+ (present rd)+ ([ext | onCA] ++ [caBC | not (isBC ext)])+ (CA $ root rd)+ (keys1 rd)+ leaf <-+ mkCertificate+ 2+ 100+ (mkDn "malformed")+ (present rd)+ ([ext | not onCA])+ (CA ca)+ (keys2 rd)+ assertValidationResult rd checks "malformed" [leaf, ca] expected+ where+ isBC (ExtensionRaw oid _ _) = oid == [2, 5, 29, 19]++-- | Signature verification with degenerate or oversized keys fails.+testBadKeys :: TestTree+testBadKeys =+ testGroup+ "bad-keys"+ [ testCase "DSA p=0" $+ verifySignature+ (SignatureALG HashSHA256 PubKeyALG_DSA)+ (PubKeyDSA (DSA.PublicKey (DSA.Params 0 2 7) 3))+ (BS.pack [1, 2, 3])+ (encodeASN1' DER [Start Sequence, IntVal 1, IntVal 1, End Sequence])+ @?= SignatureFailed SignatureInvalid+ , testCase "huge RSA modulus" $+ verifySignature+ (SignatureALG HashSHA256 PubKeyALG_RSA)+ (PubKeyRSA (RSA.PublicKey 2049 (2 ^ (16392 :: Int) - 1) 3))+ (BS.pack [1, 2, 3])+ (BS.replicate 2049 1)+ @?= SignatureFailed SignatureInvalid+ , testCase "huge RSA exponent" $+ verifySignature+ (SignatureALG HashSHA256 PubKeyALG_RSA)+ (PubKeyRSA (RSA.PublicKey 256 (2 ^ (2048 :: Int) - 1) (2 ^ (2047 :: Int) + 1)))+ (BS.pack [1, 2, 3])+ (BS.replicate 256 1)+ @?= SignatureFailed SignatureInvalid+ , testCase "tiny RSA-PSS modulus" $+ verifySignature+ (SignatureALG HashSHA256 PubKeyALG_RSAPSS)+ (PubKeyRSA (RSA.PublicKey 1 0x7f 3))+ (BS.pack [1, 2, 3])+ (BS.pack [1])+ @?= SignatureFailed SignatureInvalid+ ]++-- | Regression tests that do not depend on the signature algorithm.+treeRegression :: TestTree+treeRegression = withResource (initData AlgEd25519) freeData $ \res ->+ testGroup+ "regression"+ [ testGroup+ "name-constraints"+ [ testNameConstraints+ res+ "permitted"+ [ncEx]+ Nothing+ leafDN+ [sanExt [dns "www.example.com"]]+ "www.example.com"+ True+ , testNameConstraints+ res+ "not permitted"+ [ncEx]+ Nothing+ leafDN+ [sanExt [dns "www.google.com"]]+ "www.google.com"+ False+ , testNameConstraints+ res+ "sub-CA with excluded only"+ [ncEx]+ (Just [nameConstraints [] [dns "foo.invalid"]])+ leafDN+ [sanExt [dns "www.google.com"]]+ "www.google.com"+ False+ , testNameConstraints+ res+ "sub-CA without constraints"+ [ncEx]+ (Just [])+ leafDN+ [sanExt [dns "www.example.com"]]+ "www.example.com"+ True+ , testNameConstraints+ res+ "sub-CA without constraints (outside)"+ [ncEx]+ (Just [])+ leafDN+ [sanExt [dns "www.google.com"]]+ "www.google.com"+ False+ , testNameConstraints+ res+ "sub-CA permitted outside"+ [ncEx]+ (Just [nameConstraints [dns "google.com"] []])+ leafDN+ [sanExt [dns "www.google.com"]]+ "www.google.com"+ False+ , testNameConstraints+ res+ "CN fallback"+ [ncEx]+ Nothing+ (mkDn "www.google.com")+ []+ "www.google.com"+ False+ , testNameConstraints+ res+ "CN fallback (permitted)"+ [ncEx]+ Nothing+ (mkDn "www.example.com")+ []+ "www.example.com"+ True+ , testNameConstraints+ res+ "excluded upper case"+ [nameConstraints [] [dns "google.com"]]+ Nothing+ leafDN+ [sanExt [dns "WWW.GOOGLE.COM"]]+ "www.google.com"+ False+ , testNameConstraints+ res+ "excluded by wildcard"+ [nameConstraints [] [dns "www.example.com"]]+ Nothing+ leafDN+ [sanExt [dns "*.example.com"]]+ "www.example.com"+ False+ , testNameConstraints+ res+ "permitted upper case"+ [nameConstraints [dns "EXAMPLE.com"] []]+ Nothing+ leafDN+ [sanExt [dns "www.example.COM"]]+ "www.example.com"+ True+ , testNameConstraints+ res+ "leading dot"+ [nameConstraints [dns ".example.com"] []]+ Nothing+ leafDN+ [sanExt [dns "www.example.com"]]+ "www.example.com"+ True+ , testNameConstraints+ res+ "leading dot (apex)"+ [nameConstraints [dns ".example.com"] []]+ Nothing+ leafDN+ [sanExt [dns "example.com"]]+ "example.com"+ False+ , testNameConstraints+ res+ "excluded IP"+ [nameConstraints [] [ip [8, 8, 8, 8, 255, 255, 255, 255]]]+ Nothing+ leafDN+ [sanExt [dns "www.example.com", ip [8, 8, 8, 8]]]+ "www.example.com"+ False+ , testNameConstraints+ res+ "permitted IP"+ [nameConstraints [ip [10, 0, 0, 0, 255, 0, 0, 0]] []]+ Nothing+ leafDN+ [sanExt [dns "x.example", ip [10, 1, 2, 3]]]+ "10.1.2.3"+ True+ , testNameConstraints+ res+ "not permitted IP"+ [nameConstraints [ip [10, 0, 0, 0, 255, 0, 0, 0]] []]+ Nothing+ leafDN+ [sanExt [dns "x.example", ip [11, 1, 2, 3]]]+ "11.1.2.3"+ False+ , testNameConstraints+ res+ "IP not constrained by DNS"+ [ncEx]+ Nothing+ leafDN+ [sanExt [dns "www.example.com", ip [8, 8, 8, 8]]]+ "8.8.8.8"+ True+ , testNameConstraints+ res+ "excluded email"+ [nameConstraints [] [AltNameRFC822 "example.org"]]+ Nothing+ leafDN+ [sanExt [dns "www.example.com", AltNameRFC822 "a@EXAMPLE.org"]]+ "www.example.com"+ False+ , testNameConstraints+ res+ "excluded URI"+ [nameConstraints [] [AltNameURI ".example.org"]]+ Nothing+ leafDN+ [sanExt [dns "www.example.com", AltNameURI "https://www.example.org/"]]+ "www.example.com"+ False+ , testNameConstraints+ res+ "permitted DN"+ [nameConstraints [AltNameDN (mkDn "leaf")] []]+ Nothing+ leafDN+ [sanExt [dns "www.example.com"]]+ "www.example.com"+ True+ , testNameConstraints+ res+ "excluded DN"+ [nameConstraints [] [AltNameDN (mkDn "LEAF")]]+ Nothing+ leafDN+ [sanExt [dns "www.example.com"]]+ "www.example.com"+ False+ , testNameConstraints+ res+ "unparsable"+ [ncRegisteredID]+ Nothing+ leafDN+ [sanExt [dns "www.google.com"]]+ "www.google.com"+ False+ , testSelfIssuedLeaf res "self-issued leaf"+ ]+ , testGroup+ "subject-alt-name"+ [ testNameConstraints+ res+ "unknown names skipped"+ []+ Nothing+ leafDN+ [sanUnknown]+ "www.example.com"+ True+ , testNameConstraints+ res+ "undecodable SAN"+ []+ Nothing+ (mkDn "www.example.com")+ [sanBroken]+ "www.example.com"+ False+ ]+ , testGroup+ "malformed-extensions"+ [ testMalformedExt+ res+ "CA key usage"+ True+ (raw [2, 5, 29, 15] [IntVal 1])+ defaultChecks+ [NotAllowedToSign]+ , testMalformedExt+ res+ "CA basic constraints"+ True+ (raw [2, 5, 29, 19] [IntVal 1])+ defaultChecks+ [NotAnAuthority]+ , testMalformedExt+ res+ "leaf key usage bit 9"+ False+ (raw [2, 5, 29, 15] [BitString (toBitArray (BS.pack [0x80, 0x40]) 6)])+ defaultChecks+ { checkLeafKeyUsage = [KeyUsage_digitalSignature]+ , checkFQHN = False+ }+ []+ , testMalformedExt+ res+ "leaf extended key usage"+ False+ (raw [2, 5, 29, 37] [Start Sequence, IntVal 1, End Sequence])+ defaultChecks+ { checkLeafKeyPurpose = [KeyUsagePurpose_ServerAuth]+ , checkFQHN = False+ }+ [LeafKeyPurposeNotAllowed]+ ]+ , testGroup+ "chain-length"+ [ testLongChain res "short" 5 True+ , testLongChain res "too long" 25 False+ ]+ , testBadKeys+ ]+ where+ dns = AltNameDNS+ ip = AltNameIP . BS.pack+ leafDN = mkDn "leaf"+ ncEx = nameConstraints [dns "example.com"] []+ raw oid asn1 = ExtensionRaw oid True (encodeASN1' DER asn1)+ ncRegisteredID =+ raw+ [2, 5, 29, 30]+ [ Start Sequence+ , Start (Container Context 0)+ , Start Sequence+ , Other Context 2 (fromString "example.com")+ , End Sequence+ , Start Sequence+ , Other Context 8 (BS.pack [0x2a, 0x03])+ , End Sequence+ , End (Container Context 0)+ , End Sequence+ ]+ sanUnknown =+ ExtensionRaw [2, 5, 29, 17] False $+ encodeASN1'+ DER+ [ Start Sequence+ , Other Context 8 (BS.pack [0x2a, 0x03])+ , Other Context 2 (fromString "www.example.com")+ , End Sequence+ ]+ sanBroken =+ ExtensionRaw [2, 5, 29, 17] False $+ encodeASN1' DER [Start Sequence, IntVal 1, End Sequence]+ -- | All validation test cases. treeWithAlg :: TestName -> Alg pub priv -> TestTree treeWithAlg groupName alg = withResource (initData alg) freeData $ \res ->@@ -1000,6 +1487,7 @@ , treeWithAlg "ML-DSA-44" AlgMLDSA44 , treeWithAlg "ML-DSA-65" AlgMLDSA65 , treeWithAlg "ML-DSA-87" AlgMLDSA87+ , treeRegression ] where pssParams = PSS.defaultPSSParams SHA224
crypton-x509-validation.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: crypton-x509-validation-version: 1.10.0+version: 1.10.1 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>@@ -26,6 +26,7 @@ Data.X509.Validation.Fingerprint Data.X509.Validation.Cache Data.X509.Validation.Types+ Data.X509.Validation.Internal default-language: Haskell2010 ghc-options: -Wall@@ -37,7 +38,7 @@ crypton-asn1-types >=0.4.1 && <0.5, crypton-asn1-encoding >=0.10.0 && <0.11, crypton-pem >=0.2.4 && <0.4,- crypton-x509 >=1.10 && <1.11,+ crypton-x509 >=1.10.1 && <1.11, crypton-x509-store >=1.10 && <1.11, data-default, iproute >=1.2.2,