From ddbd029984f703d9c15fb646dfbbfe84d3352e0d Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 20 May 2014 18:13:01 -0400 Subject: more tlsa work --- TLSA.hs | 103 +++++++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 63 insertions(+), 40 deletions(-) (limited to 'TLSA.hs') diff --git a/TLSA.hs b/TLSA.hs index ecf033c..7fb66dc 100644 --- a/TLSA.hs +++ b/TLSA.hs @@ -7,9 +7,8 @@ module TLSA , fromByteString , toByteString , match - , Validation(..) + , IssuanceTest(..) , validate - , validate2 ) where import qualified Data.ByteString as BS @@ -30,6 +29,7 @@ import Data.Word import Data.Maybe import Data.List import Data.Monoid +import Data.Array.IArray {- INLINE fromWord8 #-} fromWord8 :: Enum a => Word8 -> a @@ -189,6 +189,7 @@ unsigned :: (Show a, ASN1Object a, Eq a) => a -> SignedExact a unsigned obj = fst $ objectToSignedExact fakeSign obj where fakeSign = const $ ("", SignatureALG_Unknown [], ()) +{- data Validation = Failed [TLSA] -- ^ All of the given constraints failed. @@ -200,9 +201,11 @@ data Validation -- 'certPubKey' should be ignored. | Passed -- ^ Valid end entity. Do not perform PKI. +-} -- comb [1,2,3] = [([],[1,2,3]),([1],[2,3]),([2,1],[3])] +comb :: [x] -> [([x],[x])] comb cs = matchLength cs $ iterate sweepLeft ([],cs) where sweepLeft (xs,y:ys) = (y:xs,ys) matchLength = zipWith (flip const) @@ -224,48 +227,67 @@ allChains op x xs | null ts = [[x]] ts = filter ((x `op`) . head . snd) $ comb xs f (as,y:bs) = map (x:) $ allChains op y (as++bs) --- | > validate2 isIssuedBy isSignedBy rs cert otherCerts --- --- * isIssuedBy - validates one link in a certificate chain --- --- * isSignedBy - True if the certificate is signed by the key --- --- * rs - A set of TLSA records obtained from DNS --- --- * cert - The end entity target cert to verify --- --- * otherCerts - Other relevent certificates +-- | These functions are used by 'validate' to determine when a certificate is +-- validly issued by another. +data IssuanceTest = IssuanceTest + { isIssuedBy :: SignedCertificate -> SignedCertificate -> Bool + -- ^ This is used to validate a single link in a certificate chain. + , isSignedBy :: SignedCertificate -> PubKey -> Bool + -- ^ This is used to check signatures for trust anchor keys that are + -- supplied via a 'TLSA' record but not otherwise present in the chain. + } + +-- | Use the the given set of 'TLSA' records to validate, or paritally validate +-- a certificate, given a list of other probably relevent certificates. Results +-- are interpreted as follows: -- --- Returns: +-- [@ Nothing @] The certificate passed validation. -- --- * @ Nothing @ - The end entity certificate is valid. +-- [@ Just \[\] @] Failed validation. -- --- * @ Just chains @ - A set of connected certificate chains. --- The certificate is valid if and only if there --- exists a chain that contains a CA certificate --- that is issued by a trust anchor. +-- [@ Just xss @] A set of certificate issued-by chains. If you trust any +-- certificate in any of these chains, you may consider the +-- certificate validated. Otherwise, it failed validation. -- -validate2 :: (SignedCertificate -> SignedCertificate -> Bool) - -> (SignedCertificate -> PubKey -> Bool) - -> [TLSA] -> SignedCertificate -> [SignedCertificate] -> Maybe [[SignedCertificate]] -validate2 isIssuedBy isSignedBy rs cert chain - | some domainIssued = Nothing - | any hasAnchor chains = Nothing - | otherwise = Just $ filter satisfiesConstraints chains - where +validate :: IssuanceTest -> [TLSA] -> SignedCertificate -> [SignedCertificate] + -> Maybe [[SignedCertificate]] +validate (IssuanceTest isIssuedBy isSignedBy) rs cert chain + | not (null domainIssued) = Nothing + | any hasAnchor chains = Nothing + | otherwise = Just $ (certv !) .: filter satisfiesConstraints chains + where domainIssued = filter (`match` cert) daneEEs - chains = allChains isIssuedBy cert chain + threshold = length chain - hasAnchor cs = some anchors - || some [ c | c <- cs, cert <- certs, c `isIssuedBy` cert ] - || some [ c | c <- cs, key <- keys, c `isSignedBy` key ] - where - (bs,ns) = partition (null . snd) $ pairings match daneTAs cs - anchors = concatMap snd ns + len = threshold + length anchor_certs + + certv :: Array Int SignedCertificate + certv = listArray (0,len) $ cert:chain ++ anchor_certs + + (.:) = fmap . fmap + + a .<+ b = (certv ! a) `isIssuedBy` (certv ! b) + + a .<- b = (certv ! a) `isSignedBy` b + + isAnchor n = or [ n > threshold + , n `elem` anchors + , any (n .<-) anchor_keys ] + + chains = allChains (.<+) 0 [1..len] + + hasAnchor = any isAnchor + + ( anchor_certs, anchor_keys, anchors ) + = ( mapMaybe rightToMaybe absent + , mapMaybe leftToMaybe absent + , fmap fst $ ns >>= snd ) + where + (bs,ns) = partition (null . snd) + $ pairings (\r (_,c) -> match r c) daneTAs + $ zip [0..] (cert:chain) absent = mapMaybe (certOrKey . fst) bs - certs = mapMaybe rightToMaybe absent - keys = mapMaybe leftToMaybe absent rightToMaybe (Right x) = Just x rightToMaybe _ = Nothing leftToMaybe (Left x) = Just x @@ -274,10 +296,8 @@ validate2 isIssuedBy isSignedBy rs cert chain satisfiesConstraints (c:cs) = any eeSatisfied pkixEEs || any caSatisfied pkixTAs where - eeSatisfied = (`match` c) - caSatisfied r = any (r `match`) cs - - some = not . null + eeSatisfied = (`match` (certv ! c)) + caSatisfied r = any ((r `match`) . (certv !)) cs r .~ u = certUsage r == u (daneEEs,rs2) = partition (.~ DomainIssued) rs @@ -285,6 +305,7 @@ validate2 isIssuedBy isSignedBy rs cert chain (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3 (pkixTAs,_) = partition (.~ CAConstraint) rs4 +pairings :: (a -> b -> Bool) -> [a] -> [b] -> [(a,[b])] pairings op = loop where loop [] cs = [] @@ -293,6 +314,7 @@ pairings op = loop [] -> (m,[]):loop ms cs (as,b:bs):_ -> (m,[b]):loop ms (as++bs) +{- validate :: [TLSA] -> SignedCertificate -> [SignedCertificate] -> Validation validate rs cert chain | some domainIssued = Passed @@ -323,6 +345,7 @@ validate rs cert chain (daneTAs,rs3) = partition (.~ TrustAnchorAssertion) rs2 (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3 (pkixTAs,_) = partition (.~ CAConstraint) rs4 +-} certOrKey :: TLSA -> Maybe (Either PubKey SignedCertificate) certOrKey tlsa@(matchingType->Match_Exact) = -- cgit v1.2.3