CVE-2026-9648

@@ -0,0 +1,66 @@
+```toml
+[advisory]
+id = "HSEC-2026-0008"
+cwe = [295]
+keywords = ["x509", "pki", "tls", "mitm", "name-constraints"]
+aliases = ["CVE-2026-9648"]
+
+[[affected]]
+package = "crypton-x509-validation"
+cvss = "CVSS:3.1/AV:N/AC:H/PR:L/UI:N/S:U/C:H/I:H/A:N"
+
+[[affected.versions]]
+introduced = "1.6.12"
+fixed = "1.9.1"
+
+[[affected]]
+package = "crypton-x509"
+cvss = "CVSS:3.1/AV:N/AC:H/PR:L/UI:N/S:U/C:H/I:H/A:N"
+
+[[affected.versions]]
+introduced = "1.7.6"
+fixed = "1.9.1"
+
+[[affected]]
+package = "x509-validation"
+cvss = "CVSS:3.1/AV:N/AC:H/PR:L/UI:N/S:U/C:H/I:H/A:N"
+
+[[affected.versions]]
+introduced = "1.4.0"
+
+[[affected]]
+package = "x509"
+cvss = "CVSS:3.1/AV:N/AC:H/PR:L/UI:N/S:U/C:H/I:H/A:N"
+
+[[affected.versions]]
+introduced = "1.4.0"
+
+[[references]]
+type = "ADVISORY"
+url = "https://www.kb.cert.org/vuls/id/862559"
+
+[[references]]
+type = "FIX"
+url = "https://github.com/kazu-yamamoto/crypton-certificate/pull/30"
+```
+
+# crypton-x509-validation and crypton-x509 do not enforce X.509 Name Constraints
+
+The `crypton-x509-validation` and `crypton-x509` libraries did not
+enforce the X.509 Name Constraints extension during certificate
+validation. The Name Constraints extension is a critical X.509
+extension that restricts the namespace (permitted and excluded
+subtrees) for which a CA is authorized to issue certificates.
+
+Without this enforcement, a TLS client would accept certificates with
+Subject Alternative Names (SANs) that fall outside the issuing CA's
+permitted subtrees. An attacker with access to a name-constrained
+sub-CA's private key could therefore issue certificates for domains
+outside the sub-CA's intended scope, enabling impersonation of
+arbitrary domains and man-in-the-middle attacks on TLS connections.
+
+The older `x509` and `x509-validation` packages are also affected but
+are no longer maintained and have no fix available.
+
+This issue was fixed in `crypton-x509-validation-1.9.1` and
+`crypton-x509-1.9.1`.

@@ -23,6 +23,8 @@ module Data.X509.Ext (
     ExtAuthorityKeyId (..),
     ExtCrlDistributionPoints (..),
     ExtNetscapeComment (..),
+    ExtNameConstraints (..),
+    GeneralSubtree (..),
     AltName (..),
     DistributionPoint (..),
     ReasonFlag (..),
@@ -32,6 +34,7 @@ module Data.X509.Ext (
     extensionGetE,
     extensionDecode,
     extensionEncode,
+    recognizedOIDs,
 ) where
 
 import Control.Applicative
@@ -221,12 +224,12 @@ instance Extension ExtSubjectKeyId where
 -- Not all name types are available, missing:
 -- otherName
 -- x400Address
--- directoryName
 -- ediPartyName
 -- registeredID
 data AltName
     = AltNameRFC822 String
     | AltNameDNS String
+    | AltNameDN DistinguishedName
     | AltNameURI String
     | AltNameIP B.ByteString
     | AltNameXMPP String
@@ -291,12 +294,14 @@ instance Extension ExtCrlDistributionPoints where
 
 parseGeneralNames :: ParseASN1 [AltName]
 parseGeneralNames = onNextContainer Sequence $ getMany getAddr
+
+getAddr :: ParseASN1 AltName
+getAddr = do
+    m <- onNextContainerMaybe (Container Context 0) getComposedAddr
+    case m of
+        Nothing -> getSimpleAddr
+        Just r -> return r
   where
-    getAddr = do
-        m <- onNextContainerMaybe (Container Context 0) getComposedAddr
-        case m of
-            Nothing -> getSimpleAddr
-            Just r -> return r
     getComposedAddr = do
         n <- getNext
         case n of
@@ -329,6 +334,11 @@ parseGeneralNames = onNextContainer Sequence $ getMany getAddr
         case n of
             (Other Context 1 b) -> return $ AltNameRFC822 $ BC.unpack b
             (Other Context 2 b) -> return $ AltNameDNS $ BC.unpack b
+            (Other Context 4 b) -> case decodeASN1' DER b of
+                Left e1 -> throwParseError $ show e1
+                Right as -> case runParseASN1 getObject as of
+                    Right dn -> return $ AltNameDN dn
+                    Left e2 -> throwParseError e2
             (Other Context 6 b) -> return $ AltNameURI $ BC.unpack b
             (Other Context 7 b) -> return $ AltNameIP b
             _ ->
@@ -339,27 +349,29 @@ encodeGeneralNames names =
     [Start Sequence]
         ++ concatMap encodeAltName names
         ++ [End Sequence]
-  where
-    encodeAltName (AltNameRFC822 n) = [Other Context 1 $ BC.pack n]
-    encodeAltName (AltNameDNS n) = [Other Context 2 $ BC.pack n]
-    encodeAltName (AltNameURI n) = [Other Context 6 $ BC.pack n]
-    encodeAltName (AltNameIP n) = [Other Context 7 $ n]
-    encodeAltName (AltNameXMPP n) =
-        [ Start (Container Context 0)
-        , OID [1, 3, 6, 1, 5, 5, 7, 8, 5]
-        , Start (Container Context 0)
-        , ASN1String $ asn1CharacterString UTF8 n
-        , End (Container Context 0)
-        , End (Container Context 0)
-        ]
-    encodeAltName (AltNameDNSSRV n) =
-        [ Start (Container Context 0)
-        , OID [1, 3, 6, 1, 5, 5, 7, 8, 5]
-        , Start (Container Context 0)
-        , ASN1String $ asn1CharacterString UTF8 n
-        , End (Container Context 0)
-        , End (Container Context 0)
-        ]
+
+encodeAltName :: AltName -> [ASN1]
+encodeAltName (AltNameRFC822 n) = [Other Context 1 $ BC.pack n]
+encodeAltName (AltNameDNS n) = [Other Context 2 $ BC.pack n]
+encodeAltName (AltNameDN dn) = [Other Context 4 $ encodeASN1' DER $ toASN1 dn []]
+encodeAltName (AltNameURI n) = [Other Context 6 $ BC.pack n]
+encodeAltName (AltNameIP n) = [Other Context 7 $ n]
+encodeAltName (AltNameXMPP n) =
+    [ Start (Container Context 0)
+    , OID [1, 3, 6, 1, 5, 5, 7, 8, 5]
+    , Start (Container Context 0)
+    , ASN1String $ asn1CharacterString UTF8 n
+    , End (Container Context 0)
+    , End (Container Context 0)
+    ]
+encodeAltName (AltNameDNSSRV n) =
+    [ Start (Container Context 0)
+    , OID [1, 3, 6, 1, 5, 5, 7, 8, 5]
+    , Start (Container Context 0)
+    , ASN1String $ asn1CharacterString UTF8 n
+    , End (Container Context 0)
+    , End (Container Context 0)
+    ]
 
 bitsToFlags :: Enum a => BitArray -> [a]
 bitsToFlags bits = concat $ flip map [0 .. (bitArrayLength bits - 1)] $ \i -> do
@@ -381,3 +393,137 @@ instance Extension ExtNetscapeComment where
     extDecode = error "Extension: Netscape Comment do not contain nested ASN1"
     extEncodeBs (ExtNetscapeComment b) = b
     extDecodeBs = Right . ExtNetscapeComment
+
+--------------------------------------------------------------------------------
+-- RFC5280
+--
+-- NameConstraints ::= SEQUENCE {
+--      permittedSubtrees       [0]     GeneralSubtrees OPTIONAL,
+--      excludedSubtrees        [1]     GeneralSubtrees OPTIONAL
+-- }
+--
+-- GeneralSubtrees ::= SEQUENCE SIZE (1..MAX) OF GeneralSubtree
+--
+-- GeneralSubtree ::= SEQUENCE {
+--      base                    GeneralName,
+--      minimum         [0]     BaseDistance DEFAULT 0,
+--      maximum         [1]     BaseDistance OPTIONAL
+-- }
+--------------------------------------------------------------------------------
+
+data GeneralSubtree = GeneralSubtree AltName Integer (Maybe Integer)
+    deriving (Show, Eq)
+
+data ExtNameConstraints = ExtNameConstraints [GeneralSubtree] [GeneralSubtree]
+    deriving (Show, Eq)
+
+instance Extension ExtNameConstraints where
+    extOID _ = [2, 5, 29, 30]
+    extHasNestedASN1 _ = True
+    extEncode = encodeNameConstraints
+    extDecode = decodeNameConstraints
+
+--------------------------------------------------------------------------------
+-- Encoding
+--------------------------------------------------------------------------------
+
+encodeNameConstraints :: ExtNameConstraints -> [ASN1]
+encodeNameConstraints (ExtNameConstraints permitted excluded) =
+    [Start Sequence]
+        ++ put 0 permitted
+        ++ put 1 excluded
+        ++ [End Sequence]
+  where
+    put _ [] = []
+    put n xs =
+        [Start (Container Context n), Start Sequence]
+            ++ concatMap encodeGeneralSubtree xs
+            ++ [End Sequence, End (Container Context n)]
+
+encodeGeneralSubtree :: GeneralSubtree -> [ASN1]
+encodeGeneralSubtree (GeneralSubtree base minimum' maximum') =
+    [Start Sequence]
+        ++ encodeAltName base
+        ++ ( if minimum' /= 0
+                then [Other Context 0 (encodeASN1' DER [IntVal minimum'])]
+                else []
+           )
+        ++ maybe
+            []
+            ( \m ->
+                [Other Context 1 (encodeASN1' DER [IntVal m])]
+            )
+            maximum'
+        ++ [End Sequence]
+
+--------------------------------------------------------------------------------
+-- Decoding
+--------------------------------------------------------------------------------
+
+decodeNameConstraints :: [ASN1] -> Either String ExtNameConstraints
+decodeNameConstraints
+    (Start Sequence : xs) =
+        go xs [] []
+      where
+        go (End Sequence : _) permitted excluded =
+            Right $ ExtNameConstraints permitted excluded
+        go (Start (Container Context 0) : rest) _ excluded = do
+            (subs, rest') <- decodeSubtrees rest
+            go rest' subs excluded
+        go (Start (Container Context 1) : rest) permitted _ = do
+            (subs, rest') <- decodeSubtrees rest
+            go rest' permitted subs
+        go _ _ _ = Left "Invalid NameConstraints"
+        decodeSubtrees :: [ASN1] -> Either String ([GeneralSubtree], [ASN1])
+        decodeSubtrees ys = loop ys []
+          where
+            loop (End (Container Context _) : rest) acc =
+                Right (reverse acc, rest)
+            loop zs acc = do
+                (s, zs') <- decodeGeneralSubtree zs
+                loop zs' (s : acc)
+decodeNameConstraints _ =
+    Left "NameConstraints: expected SEQUENCE"
+
+decodeGeneralSubtree
+    :: [ASN1]
+    -> Either String (GeneralSubtree, [ASN1])
+decodeGeneralSubtree (Start Sequence : xs) = do
+    (base, rest1) <- runParseASN1State getAddr xs
+
+    let (minimum', rest2) =
+            case rest1 of
+                (Other Context 0 bs : rs) ->
+                    case decodeASN1' DER bs of
+                        Right [IntVal n] -> (n, rs)
+                        _ -> (0, rest1)
+                _ -> (0, rest1)
+
+    let (maximum', rest3) =
+            case rest2 of
+                (Other Context 1 bs : rs) ->
+                    case decodeASN1' DER bs of
+                        Right [IntVal n] -> (Just n, rs)
+                        _ -> (Nothing, rest2)
+                _ -> (Nothing, rest2)
+
+    case rest3 of
+        (End Sequence : rs) ->
+            Right (GeneralSubtree base minimum' maximum', rs)
+        _ ->
+            Left "GeneralSubtree: missing end sequence"
+decodeGeneralSubtree _ =
+    Left "GeneralSubtree: invalid ASN1"
+
+recognizedOIDs :: [OID]
+recognizedOIDs =
+    [ [2, 5, 29, 19] -- ExtBasicConstraints
+    , [2, 5, 29, 15] -- ExtKeyUsage
+    , [2, 5, 29, 37] -- ExtExtendedKeyUsage
+    , [2, 5, 29, 14] -- ExtSubjectKeyId
+    , [2, 5, 29, 17] -- ExtSubjectAltName
+    , [2, 5, 29, 35] -- ExtAuthorityKeyId
+    , [2, 5, 29, 31] -- ExtCrlDistributionPoints
+    , [2, 5, 29, 30] -- ExtNameConstraints
+    , [2, 16, 840, 1, 113730, 1, 13] -- ExtNetscapeComment
+    ]

@@ -91,6 +91,9 @@ showExts es@(Extensions (Just exts)) = do
     showKnownExtension
         "authority-key-id"
         (X509.extensionGetE es :: Maybe (Either String X509.ExtAuthorityKeyId))
+    showKnownExtension
+        "name-constraint"
+        (X509.extensionGetE es :: Maybe (Either String X509.ExtNameConstraints))
   where
     showExt er = do
         putStrLn

@@ -65,7 +65,7 @@ import Time.System
 -- instead.
 data FailedReason
     = -- | certificate contains an unknown critical extension
-      UnknownCriticalExtension
+      UnknownCriticalExtension OID
     | -- | validity ends before checking time
       Expired
     | -- | validity starts after checking time
@@ -272,12 +272,21 @@ validatePure
     -- ^ the return failed reasons (empty list is no failure)
 validatePure _ _ _ _ _ (CertificateChain []) = [EmptyChain]
 validatePure validationTime hooks checks store (fqhn, _) (CertificateChain (top : rchain)) =
-    hookFilterReason hooks (doLeafChecks |> doCheckChain 0 top rchain)
+    hookFilterReason
+        hooks
+        (doLeafChecks |> doCheckChain 0 top rchain |> doCheckNameConst top rchain)
   where
+    isExhaustive :: Bool
     isExhaustive = checkExhaustive checks
+
+    (|>) :: [FailedReason] -> [FailedReason] -> [FailedReason]
     a |> b = exhaustive isExhaustive a b
 
-    doLeafChecks = doNameCheck top ++ doV3Check topCert ++ doKeyUsageCheck topCert
+    doLeafChecks :: [FailedReason]
+    doLeafChecks =
+        doNameCheck top
+            ++ doV3Check topCert
+            ++ doKeyUsageCheck topCert
       where
         topCert = getCertificate top
 
@@ -300,9 +309,14 @@ validatePure validationTime hooks checks store (fqhn, _) (CertificateChain (top
                                         |> doCheckChain (level + 1) issuer remaining
                )
       where
+        cert :: Certificate
         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
+        :: DistinguishedName
+        -> [SignedCertificate]
+        -> Maybe (SignedCertificate, [SignedCertificate])
     findIssuer issuerDN chain
         | checkStrictOrdering checks =
             case chain of
@@ -313,6 +327,7 @@ validatePure validationTime hooks checks store (fqhn, _) (CertificateChain (top
         | otherwise =
             (\x -> (x, filter (/= x) chain))
                 `fmap` find (matchSubjectIdentifier issuerDN . getCertificate) chain
+    matchSubjectIdentifier :: DistinguishedName -> Certificate -> Bool
     matchSubjectIdentifier = hookMatchSubjectIssuer hooks
 
     -- we check here that the certificate is allowed to be a certificate
@@ -342,16 +357,19 @@ validatePure validationTime hooks checks store (fqhn, _) (CertificateChain (top
                 | fromIntegral pl >= level -> True
                 | otherwise -> False
 
+    doNameCheck :: SignedCertificate -> [FailedReason]
     doNameCheck cert
         | not (checkFQHN checks) = []
         | otherwise = (hookValidateName hooks) fqhn (getCertificate cert)
 
+    doV3Check :: Certificate -> [FailedReason]
     doV3Check cert
         | checkLeafV3 checks = case certVersion cert of
             2 {- confusingly it means X509.V3 -} -> []
             _ -> [LeafNotV3]
         | otherwise = []
 
+    doKeyUsageCheck :: Certificate -> [FailedReason]
     doKeyUsageCheck cert =
         compareListIfExistAndNotNull
             mflags
@@ -377,20 +395,64 @@ validatePure validationTime hooks checks store (fqhn, _) (CertificateChain (top
             | intersect expected list == expected = []
             | otherwise = [err]
 
+    doCheckCertificate :: Certificate -> [FailedReason]
     doCheckCertificate cert =
         exhaustiveList
             (checkExhaustive checks)
             [ (checkTimeValidity checks, hookValidateTime hooks validationTime cert)
+            , (True, doCriticalExtensionSweep cert)
             ]
-    isSelfSigned :: Certificate -> Bool
-    isSelfSigned cert = certSubjectDN cert == certIssuerDN cert
-
     -- check signature of 'signedCert' against the 'signingCert'
+    checkSignature
+        :: SignedCertificate -> SignedCertificate -> [FailedReason]
     checkSignature signedCert signingCert =
         case verifySignedSignature signedCert (certPubKey $ getCertificate signingCert) of
             SignaturePass -> []
             SignatureFailed r -> [InvalidSignature r]
 
+    doCheckNameConst :: SignedCertificate -> [SignedCertificate] -> [FailedReason]
+    doCheckNameConst current0 chain0 = case loop 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)
+          where
+            cert = getCertificate current
+            issuer = certIssuerDN cert
+            spec = getNameConstSpec cert (current0 /= current)
+
+isSelfSigned :: Certificate -> Bool
+isSelfSigned cert = certSubjectDN cert == certIssuerDN cert
+
+data NameConstSpec = NameConstSpec
+    { ncSANs :: [AltName]
+    , ncExt :: Maybe ExtNameConstraints
+    , ncSelfSigned :: Bool
+    , ncCA :: Bool
+    }
+
+getNameConstSpec :: Certificate -> Bool -> NameConstSpec
+getNameConstSpec cert ca =
+    NameConstSpec
+        { ncSANs = sans
+        , ncExt = extensionGet exts
+        , ncSelfSigned = isSelfSigned cert
+        , ncCA = ca
+        }
+  where
+    exts = certExtensions cert
+    subj = AltNameDN $ certSubjectDN cert
+    sans :: [AltName]
+    sans = case extensionGet exts of
+        Nothing -> [subj]
+        Just (ExtSubjectAltName alts) -> subj : alts
+
 -- | Validate that the current time is between validity bounds
 validateTime :: DateTime -> Certificate -> [FailedReason]
 validateTime currentTime cert
@@ -523,3 +585,91 @@ exhaustiveList _ [] = []
 exhaustiveList isExhaustive ((performCheck, c) : cs)
     | performCheck = exhaustive isExhaustive c (exhaustiveList isExhaustive cs)
     | otherwise = exhaustiveList isExhaustive cs
+
+checkNameConstraints :: [NameConstSpec] -> [FailedReason]
+checkNameConstraints xs0 = loop xs0
+  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
+      where
+        errs = strictCheck permitted0 permitted1
+
+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]
+
+validateNamesInSubtrees :: [AltName] -> ExtNameConstraints -> [FailedReason]
+validateNamesInSubtrees altNames (ExtNameConstraints permitted excluded) =
+    concatMap inc altNames ++ concatMap exc altNames
+  where
+    inc a
+        | nsMatch a permitted = []
+        | otherwise = [InvalidName $ show a]
+    exc a
+        | nsNotMatch a excluded = []
+        | otherwise = [InvalidName $ show a]
+
+nsMatch :: AltName -> [GeneralSubtree] -> Bool
+nsMatch a gs = any (== Just True) rs || all isNothing rs
+  where
+    rs = map (a `isIncludedIn`) gs
+
+nsNotMatch :: AltName -> [GeneralSubtree] -> Bool
+nsNotMatch a gs = all (\g -> (a `isIncludedIn` g) /= Just True) gs
+
+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
+
+doCriticalExtensionSweep :: Certificate -> [FailedReason]
+doCriticalExtensionSweep cert = case mexts of
+    Nothing -> []
+    Just exts ->
+        [ UnknownCriticalExtension oid
+        | ExtensionRaw oid critical _ <- exts
+        , critical
+        , oid `notElem` recognizedOIDs
+        ]
+  where
+    Extensions mexts = certExtensions cert