crypton-x509-validation 1.9.0 → 1.9.1
raw patch · 3 files changed
+162/−7 lines, 3 filesdep ~crypton-x509
Dependency ranges changed: crypton-x509
Files
- ChangeLog.md +5/−0
- Data/X509/Validation.hs +156/−6
- crypton-x509-validation.cabal +1/−1
ChangeLog.md view
@@ -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"
Data/X509/Validation.hs view
@@ -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
crypton-x509-validation.cabal view
@@ -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 <vincent@snarc.org>