crypton-x509-validation 1.6.14 → 1.9.1
raw patch · 4 files changed
Files
- ChangeLog.md +19/−0
- Data/X509/Validation.hs +157/−7
- Tests/Tests.hs +58/−4
- crypton-x509-validation.cabal +65/−60
+ ChangeLog.md view
@@ -0,0 +1,19 @@+# 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"+ [#29](https://github.com/kazu-yamamoto/crypton-certificate/pull/29)++## 1.8.0++* Depend on package `time-hourglass`, rather than `hourglass`. Date and+ time-related types and classes are now those from the former package.+ [#18](https://github.com/kazu-yamamoto/crypton-certificate/pull/18)+* Depend on package `crypton-asn1-types >= 0.4.1` rather than `asn1-types`.+ ASN.1-related types and classes are now those from the former package.
Data/X509/Validation.hs view
@@ -55,8 +55,8 @@ import Data.X509.Validation.Fingerprint import Data.X509.Validation.Signature import Data.X509.Validation.Types-import System.Hourglass import Text.Read (readMaybe)+import Time.System -- | Possible reason of certificate and chain failure. --@@ -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
Tests/Tests.hs view
@@ -20,7 +20,7 @@ import qualified Data.ByteString as BS import Data.Hourglass-import System.Hourglass+import Time.System import Test.Tasty import Test.Tasty.HUnit@@ -863,19 +863,73 @@ [NameMismatch "266.0.0.1"] -- 266 read in Word8 is 10 , testSubjectAltNameIP res- (BS.pack [0x20, 0x01, 0x0d, 0xb8, 0x85, 0xa3, 0, 0, 0, 0, 0x8a, 0x2e, 0x03, 0x70, 0x73, 0x34])+ ( BS.pack+ [ 0x20+ , 0x01+ , 0x0d+ , 0xb8+ , 0x85+ , 0xa3+ , 0+ , 0+ , 0+ , 0+ , 0x8a+ , 0x2e+ , 0x03+ , 0x70+ , 0x73+ , 0x34+ ]+ ) "2001:0db8:85a3:0000:0000:8a2e:0370:7334" True [] , testSubjectAltNameIP res- (BS.pack [0x20, 0x01, 0x0d, 0xb8, 0x85, 0xa3, 0, 0, 0, 0, 0x8a, 0x2e, 0x03, 0x70, 0x73, 0x34])+ ( BS.pack+ [ 0x20+ , 0x01+ , 0x0d+ , 0xb8+ , 0x85+ , 0xa3+ , 0+ , 0+ , 0+ , 0+ , 0x8a+ , 0x2e+ , 0x03+ , 0x70+ , 0x73+ , 0x34+ ]+ ) "2001:0db8:85a3::8a2e:0370:7334" True [] , testSubjectAltNameIP res- (BS.pack [0x20, 0x01, 0x0d, 0xb8, 0x85, 0xa3, 0, 0, 0, 0, 0x8a, 0x2e, 0x03, 0x70, 0x73, 0x34])+ ( BS.pack+ [ 0x20+ , 0x01+ , 0x0d+ , 0xb8+ , 0x85+ , 0xa3+ , 0+ , 0+ , 0+ , 0+ , 0x8a+ , 0x2e+ , 0x03+ , 0x70+ , 0x73+ , 0x34+ ]+ ) "2001:0db8:85a3:0:0:8a2e:0370:7334" True []
crypton-x509-validation.cabal view
@@ -1,63 +1,68 @@-Name: crypton-x509-validation-version: 1.6.14-Description: X.509 Certificate and CRL validation. please see README-License: BSD3-License-file: LICENSE-Copyright: Vincent Hanquez <vincent@snarc.org>-Author: Vincent Hanquez <vincent@snarc.org>-Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>-Synopsis: X.509 Certificate and CRL validation-Build-Type: Simple-Category: Data-stability: experimental-Homepage: https://github.com/kazu-yamamoto/crypton-certificate-Cabal-Version: >= 1.10+cabal-version: >=1.10+name: crypton-x509-validation+version: 1.9.1+license: BSD3+license-file: LICENSE+copyright: Vincent Hanquez <vincent@snarc.org>+maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+author: Vincent Hanquez <vincent@snarc.org>+stability: experimental+homepage: https://github.com/kazu-yamamoto/crypton-certificate+synopsis: X.509 Certificate and CRL validation+description: X.509 Certificate and CRL validation. please see README+category: Data+build-type: Simple+extra-source-files: ChangeLog.md -Library- Default-Language: Haskell2010- Build-Depends: base >= 3 && < 5- , bytestring- , memory- , mtl- , containers- , hourglass- , data-default- , pem >= 0.1- , asn1-types >= 0.3 && < 0.4- , asn1-encoding >= 0.9 && < 0.10- , crypton-x509 >= 1.7.5- , crypton-x509-store >= 1.6- , crypton >= 0.24- , iproute >= 1.2.2- Exposed-modules: Data.X509.Validation- Other-modules: Data.X509.Validation.Signature- Data.X509.Validation.Fingerprint- Data.X509.Validation.Cache- Data.X509.Validation.Types- ghc-options: -Wall+source-repository head+ type: git+ location: https://github.com/kazu-yamamoto/crypton-certificate+ subdir: x509-validation -Test-Suite test-x509-validation- Default-Language: Haskell2010- type: exitcode-stdio-1.0- hs-source-dirs: Tests- Main-is: Tests.hs- Other-modules: Certificate- Build-Depends: base >= 3 && < 5- , bytestring- , memory- , data-default- , tasty- , tasty-hunit- , hourglass- , asn1-types- , asn1-encoding- , crypton-x509 >= 1.7.1- , crypton-x509-store- , crypton-x509-validation- , crypton- ghc-options: -Wall+library+ exposed-modules: Data.X509.Validation+ other-modules:+ Data.X509.Validation.Signature+ Data.X509.Validation.Fingerprint+ Data.X509.Validation.Cache+ Data.X509.Validation.Types -source-repository head- type: git- location: https://github.com/kazu-yamamoto/crypton-certificate- subdir: x509-validation+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=3 && <5,+ bytestring,+ containers,+ crypton >=1.1 && < 1.2,+ 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.9.0 && <1.10,+ crypton-x509-store >=1.9.0 && <1.10,+ data-default,+ iproute >=1.2.2,+ mtl,+ ram,+ time-hourglass++test-suite test-x509-validation+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs: Tests+ other-modules: Certificate+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=3 && <5,+ bytestring,+ crypton,+ crypton-asn1-encoding,+ crypton-asn1-types,+ crypton-x509,+ crypton-x509-store,+ crypton-x509-validation,+ data-default,+ ram,+ tasty,+ tasty-hunit,+ time-hourglass