summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--TLSA.hs103
1 files changed, 63 insertions, 40 deletions
diff --git a/TLSA.hs b/TLSA.hs
index ecf033c..7fb66dc 100644
--- a/TLSA.hs
+++ b/TLSA.hs
@@ -7,9 +7,8 @@ module TLSA
7 , fromByteString 7 , fromByteString
8 , toByteString 8 , toByteString
9 , match 9 , match
10 , Validation(..) 10 , IssuanceTest(..)
11 , validate 11 , validate
12 , validate2
13 ) where 12 ) where
14 13
15import qualified Data.ByteString as BS 14import qualified Data.ByteString as BS
@@ -30,6 +29,7 @@ import Data.Word
30import Data.Maybe 29import Data.Maybe
31import Data.List 30import Data.List
32import Data.Monoid 31import Data.Monoid
32import Data.Array.IArray
33 33
34{- INLINE fromWord8 #-} 34{- INLINE fromWord8 #-}
35fromWord8 :: Enum a => Word8 -> a 35fromWord8 :: Enum a => Word8 -> a
@@ -189,6 +189,7 @@ unsigned :: (Show a, ASN1Object a, Eq a) => a -> SignedExact a
189unsigned obj = fst $ objectToSignedExact fakeSign obj 189unsigned obj = fst $ objectToSignedExact fakeSign obj
190 where fakeSign = const $ ("", SignatureALG_Unknown [], ()) 190 where fakeSign = const $ ("", SignatureALG_Unknown [], ())
191 191
192{-
192data Validation 193data Validation
193 = Failed [TLSA] 194 = Failed [TLSA]
194 -- ^ All of the given constraints failed. 195 -- ^ All of the given constraints failed.
@@ -200,9 +201,11 @@ data Validation
200 -- 'certPubKey' should be ignored. 201 -- 'certPubKey' should be ignored.
201 | Passed 202 | Passed
202 -- ^ Valid end entity. Do not perform PKI. 203 -- ^ Valid end entity. Do not perform PKI.
204-}
203 205
204 206
205-- comb [1,2,3] = [([],[1,2,3]),([1],[2,3]),([2,1],[3])] 207-- comb [1,2,3] = [([],[1,2,3]),([1],[2,3]),([2,1],[3])]
208comb :: [x] -> [([x],[x])]
206comb cs = matchLength cs $ iterate sweepLeft ([],cs) 209comb cs = matchLength cs $ iterate sweepLeft ([],cs)
207 where sweepLeft (xs,y:ys) = (y:xs,ys) 210 where sweepLeft (xs,y:ys) = (y:xs,ys)
208 matchLength = zipWith (flip const) 211 matchLength = zipWith (flip const)
@@ -224,48 +227,67 @@ allChains op x xs | null ts = [[x]]
224 ts = filter ((x `op`) . head . snd) $ comb xs 227 ts = filter ((x `op`) . head . snd) $ comb xs
225 f (as,y:bs) = map (x:) $ allChains op y (as++bs) 228 f (as,y:bs) = map (x:) $ allChains op y (as++bs)
226 229
227-- | > validate2 isIssuedBy isSignedBy rs cert otherCerts 230-- | These functions are used by 'validate' to determine when a certificate is
228-- 231-- validly issued by another.
229-- * isIssuedBy - validates one link in a certificate chain 232data IssuanceTest = IssuanceTest
230-- 233 { isIssuedBy :: SignedCertificate -> SignedCertificate -> Bool
231-- * isSignedBy - True if the certificate is signed by the key 234 -- ^ This is used to validate a single link in a certificate chain.
232-- 235 , isSignedBy :: SignedCertificate -> PubKey -> Bool
233-- * rs - A set of TLSA records obtained from DNS 236 -- ^ This is used to check signatures for trust anchor keys that are
234-- 237 -- supplied via a 'TLSA' record but not otherwise present in the chain.
235-- * cert - The end entity target cert to verify 238 }
236-- 239
237-- * otherCerts - Other relevent certificates 240-- | Use the the given set of 'TLSA' records to validate, or paritally validate
241-- a certificate, given a list of other probably relevent certificates. Results
242-- are interpreted as follows:
238-- 243--
239-- Returns: 244-- [@ Nothing @] The certificate passed validation.
240-- 245--
241-- * @ Nothing @ - The end entity certificate is valid. 246-- [@ Just \[\] @] Failed validation.
242-- 247--
243-- * @ Just chains @ - A set of connected certificate chains. 248-- [@ Just xss @] A set of certificate issued-by chains. If you trust any
244-- The certificate is valid if and only if there 249-- certificate in any of these chains, you may consider the
245-- exists a chain that contains a CA certificate 250-- certificate validated. Otherwise, it failed validation.
246-- that is issued by a trust anchor.
247-- 251--
248validate2 :: (SignedCertificate -> SignedCertificate -> Bool) 252validate :: IssuanceTest -> [TLSA] -> SignedCertificate -> [SignedCertificate]
249 -> (SignedCertificate -> PubKey -> Bool) 253 -> Maybe [[SignedCertificate]]
250 -> [TLSA] -> SignedCertificate -> [SignedCertificate] -> Maybe [[SignedCertificate]] 254validate (IssuanceTest isIssuedBy isSignedBy) rs cert chain
251validate2 isIssuedBy isSignedBy rs cert chain 255 | not (null domainIssued) = Nothing
252 | some domainIssued = Nothing 256 | any hasAnchor chains = Nothing
253 | any hasAnchor chains = Nothing 257 | otherwise = Just $ (certv !) .: filter satisfiesConstraints chains
254 | otherwise = Just $ filter satisfiesConstraints chains 258 where
255 where
256 domainIssued = filter (`match` cert) daneEEs 259 domainIssued = filter (`match` cert) daneEEs
257 260
258 chains = allChains isIssuedBy cert chain 261 threshold = length chain
259 262
260 hasAnchor cs = some anchors 263 len = threshold + length anchor_certs
261 || some [ c | c <- cs, cert <- certs, c `isIssuedBy` cert ] 264
262 || some [ c | c <- cs, key <- keys, c `isSignedBy` key ] 265 certv :: Array Int SignedCertificate
263 where 266 certv = listArray (0,len) $ cert:chain ++ anchor_certs
264 (bs,ns) = partition (null . snd) $ pairings match daneTAs cs 267
265 anchors = concatMap snd ns 268 (.:) = fmap . fmap
269
270 a .<+ b = (certv ! a) `isIssuedBy` (certv ! b)
271
272 a .<- b = (certv ! a) `isSignedBy` b
273
274 isAnchor n = or [ n > threshold
275 , n `elem` anchors
276 , any (n .<-) anchor_keys ]
277
278 chains = allChains (.<+) 0 [1..len]
279
280 hasAnchor = any isAnchor
281
282 ( anchor_certs, anchor_keys, anchors )
283 = ( mapMaybe rightToMaybe absent
284 , mapMaybe leftToMaybe absent
285 , fmap fst $ ns >>= snd )
286 where
287 (bs,ns) = partition (null . snd)
288 $ pairings (\r (_,c) -> match r c) daneTAs
289 $ zip [0..] (cert:chain)
266 absent = mapMaybe (certOrKey . fst) bs 290 absent = mapMaybe (certOrKey . fst) bs
267 certs = mapMaybe rightToMaybe absent
268 keys = mapMaybe leftToMaybe absent
269 rightToMaybe (Right x) = Just x 291 rightToMaybe (Right x) = Just x
270 rightToMaybe _ = Nothing 292 rightToMaybe _ = Nothing
271 leftToMaybe (Left x) = Just x 293 leftToMaybe (Left x) = Just x
@@ -274,10 +296,8 @@ validate2 isIssuedBy isSignedBy rs cert chain
274 satisfiesConstraints (c:cs) = any eeSatisfied pkixEEs 296 satisfiesConstraints (c:cs) = any eeSatisfied pkixEEs
275 || any caSatisfied pkixTAs 297 || any caSatisfied pkixTAs
276 where 298 where
277 eeSatisfied = (`match` c) 299 eeSatisfied = (`match` (certv ! c))
278 caSatisfied r = any (r `match`) cs 300 caSatisfied r = any ((r `match`) . (certv !)) cs
279
280 some = not . null
281 301
282 r .~ u = certUsage r == u 302 r .~ u = certUsage r == u
283 (daneEEs,rs2) = partition (.~ DomainIssued) rs 303 (daneEEs,rs2) = partition (.~ DomainIssued) rs
@@ -285,6 +305,7 @@ validate2 isIssuedBy isSignedBy rs cert chain
285 (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3 305 (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3
286 (pkixTAs,_) = partition (.~ CAConstraint) rs4 306 (pkixTAs,_) = partition (.~ CAConstraint) rs4
287 307
308pairings :: (a -> b -> Bool) -> [a] -> [b] -> [(a,[b])]
288pairings op = loop 309pairings op = loop
289 where 310 where
290 loop [] cs = [] 311 loop [] cs = []
@@ -293,6 +314,7 @@ pairings op = loop
293 [] -> (m,[]):loop ms cs 314 [] -> (m,[]):loop ms cs
294 (as,b:bs):_ -> (m,[b]):loop ms (as++bs) 315 (as,b:bs):_ -> (m,[b]):loop ms (as++bs)
295 316
317{-
296validate :: [TLSA] -> SignedCertificate -> [SignedCertificate] -> Validation 318validate :: [TLSA] -> SignedCertificate -> [SignedCertificate] -> Validation
297validate rs cert chain 319validate rs cert chain
298 | some domainIssued = Passed 320 | some domainIssued = Passed
@@ -323,6 +345,7 @@ validate rs cert chain
323 (daneTAs,rs3) = partition (.~ TrustAnchorAssertion) rs2 345 (daneTAs,rs3) = partition (.~ TrustAnchorAssertion) rs2
324 (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3 346 (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3
325 (pkixTAs,_) = partition (.~ CAConstraint) rs4 347 (pkixTAs,_) = partition (.~ CAConstraint) rs4
348-}
326 349
327certOrKey :: TLSA -> Maybe (Either PubKey SignedCertificate) 350certOrKey :: TLSA -> Maybe (Either PubKey SignedCertificate)
328certOrKey tlsa@(matchingType->Match_Exact) = 351certOrKey tlsa@(matchingType->Match_Exact) =