diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # ChangeLog for crypton-x509-validation +## 1.9.1 + +* Implementing the X509 name constrains extension. + [#30](https://github.com/kazu-yamamoto/crypton-certificate/pull/30) + ## 1.9.0 * Using "ram" instead of "memory" diff --git a/Data/X509/Validation.hs b/Data/X509/Validation.hs --- a/Data/X509/Validation.hs +++ b/Data/X509/Validation.hs @@ -65,7 +65,7 @@ -- 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 @@ -- ^ 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 @@ |> 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 @@ | 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 @@ | 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 @@ | 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 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 diff --git a/crypton-x509-validation.cabal b/crypton-x509-validation.cabal --- a/crypton-x509-validation.cabal +++ b/crypton-x509-validation.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: crypton-x509-validation -version: 1.9.0 +version: 1.9.1 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez