summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--TLSA.hs118
1 files changed, 45 insertions, 73 deletions
diff --git a/TLSA.hs b/TLSA.hs
index 01c9a09..8bc4203 100644
--- a/TLSA.hs
+++ b/TLSA.hs
@@ -21,7 +21,6 @@ import Data.X509 {- ( certPubKey, Certificate(..), SignedCertificate, ge
21 , encodeSignedObject, decodeSignedObject ) -} 21 , encodeSignedObject, decodeSignedObject ) -}
22import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 ) 22import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 )
23import Data.ASN1.Encoding ( encodeASN1, decodeASN1 ) 23import Data.ASN1.Encoding ( encodeASN1, decodeASN1 )
24import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
25 24
26import Data.ASN1.BinaryEncoding 25import Data.ASN1.BinaryEncoding
27import Control.Applicative 26import Control.Applicative
@@ -44,17 +43,20 @@ toWord8 = toEnum . fromEnum
44-- It is used by the 'validate' function in making a 'Validation' decision. 43-- It is used by the 'validate' function in making a 'Validation' decision.
45data CertUsage 44data CertUsage
46 45
47 -- | This usage limits which CA can be used to issue certificates for a 46 -- | This is usage value 0 in RFC 6698. Any CA certificate that 'match'es
48 -- given service on a host. PKIX-validated TLS connections for the domain 47 -- the 'TSLA' record is acceptable. If the chain cannot be validated via
49 -- should be considered invalid if the certification path does not include 48 -- 'TLSA' records alone (using 'TrustAnchorAssertion' or 'DomainIssued'),
50 -- at least one certificate that 'match'es the 'TLSA' record. 49 -- and there are any usable 'TLSA' records at all, then the 'validate'
51 = CAConstraint 50 -- function will require at least one acceptable certificate.
52 51 = AcceptableCA
53 -- | This usage limits which end entity certificate can be used by a given 52
54 -- service on a host. The TLS connection for the domain should be 53 -- | This is usage value 1 in RFC 6698. If the target certificate
55 -- considered invalid if the end entity certificate does not 'match' the 54 -- 'match'es, then it is considered acceptable. If the chain cannot be
56 -- 'TLSA' record. 55 -- validated via 'TLSA' records alone (using 'TrustAnchorAssertion' or
57 | ServiceCertificateConstraint 56 -- 'DomainIssued'), and there are any usable 'TLSA' records at all, then
57 -- the 'validate' function will require at least one acceptable
58 -- certificate.
59 | AcceptableEE
58 60
59 -- | This usage allows a domain name administrator to specify a new trust 61 -- | This usage allows a domain name administrator to specify a new trust
60 -- anchor. This is useful if the domain issues its own certificates under 62 -- anchor. This is useful if the domain issues its own certificates under
@@ -67,20 +69,20 @@ data CertUsage
67 -- | This usage allows for a domain name administrator to issue 69 -- | This usage allows for a domain name administrator to issue
68 -- certificates for a domain without involving a third-party CA. The end 70 -- certificates for a domain without involving a third-party CA. The end
69 -- entity certificate MUST 'match' the 'TLSA' record. Unlike for a 71 -- entity certificate MUST 'match' the 'TLSA' record. Unlike for a
70 -- 'ServiceCertificateConstraint', PKIX validation should not be performed. 72 -- 'AcceptableEE', PKIX validation should not be performed.
71 | DomainIssued 73 | DomainIssued
72 74
73 | CertUsage Word8 75 | CertUsage Word8 -- ^ Unusable.
74 deriving (Eq, Ord, Show, Read) 76 deriving (Eq, Ord, Show, Read)
75 77
76instance Enum CertUsage where 78instance Enum CertUsage where
77 fromEnum CAConstraint = 0 79 fromEnum AcceptableCA = 0
78 fromEnum ServiceCertificateConstraint = 1 80 fromEnum AcceptableEE = 1
79 fromEnum TrustAnchorAssertion = 2 81 fromEnum TrustAnchorAssertion = 2
80 fromEnum DomainIssued = 3 82 fromEnum DomainIssued = 3
81 fromEnum (CertUsage n) = fromEnum n 83 fromEnum (CertUsage n) = fromEnum n
82 toEnum 0 = CAConstraint 84 toEnum 0 = AcceptableCA
83 toEnum 1 = ServiceCertificateConstraint 85 toEnum 1 = AcceptableEE
84 toEnum 2 = TrustAnchorAssertion 86 toEnum 2 = TrustAnchorAssertion
85 toEnum 3 = DomainIssued 87 toEnum 3 = DomainIssued
86 toEnum n = CertUsage (toEnum n) 88 toEnum n = CertUsage (toEnum n)
@@ -185,24 +187,6 @@ match tlsa cert = fromMaybe False $
185 Match_SHA512 -> Just SHA512.hashlazy 187 Match_SHA512 -> Just SHA512.hashlazy
186 _ -> Nothing 188 _ -> Nothing
187 189
188unsigned :: (Show a, ASN1Object a, Eq a) => a -> SignedExact a
189unsigned obj = fst $ objectToSignedExact fakeSign obj
190 where fakeSign = const $ ("", SignatureALG_Unknown [], ())
191
192{-
193data Validation
194 = Failed [TLSA]
195 -- ^ All of the given constraints failed.
196 | TrustAnchors [SignedCertificate] [SignedCertificate]
197 -- ^ Perform PKI validation with the given additional trust anchors. The
198 -- first list are trust anchors that occured in the chain. The second list
199 -- are anchors that did not occur in the chain. If 'certVersion' == (-1)
200 -- for any certificate in the second list, then all fields except
201 -- 'certPubKey' should be ignored.
202 | Passed
203 -- ^ Valid end entity. Do not perform PKI.
204-}
205
206 190
207-- comb [1,2,3] = [([],[1,2,3]),([1],[2,3]),([2,1],[3])] 191-- comb [1,2,3] = [([],[1,2,3]),([1],[2,3]),([2,1],[3])]
208comb :: [x] -> [([x],[x])] 192comb :: [x] -> [([x],[x])]
@@ -210,6 +194,7 @@ comb cs = matchLength cs $ iterate sweepLeft ([],cs)
210 where sweepLeft (xs,y:ys) = (y:xs,ys) 194 where sweepLeft (xs,y:ys) = (y:xs,ys)
211 matchLength = zipWith (flip const) 195 matchLength = zipWith (flip const)
212 196
197{-
213-- O(n²) worst case 198-- O(n²) worst case
214-- O(n) best case 199-- O(n) best case
215-- op is an antisymmetric operation 200-- op is an antisymmetric operation
@@ -218,14 +203,28 @@ connectedChain op x xs =
218 case filter ((x `op`) . snd) $ comb xs of 203 case filter ((x `op`) . snd) $ comb xs of
219 [] -> [x] 204 [] -> [x]
220 (as,y:bs):_ -> x : connectedChain op y (bs++as) 205 (as,y:bs):_ -> x : connectedChain op y (bs++as)
206-}
221 207
208-- | > allChains rel x xs
209--
210-- Given a relation @rel@, a starting element @x@ and a collection of similarly
211-- typed elements @xs@, returns the set of all ordered subsets @ks@ of @x:xs@
212-- such that:
213--
214-- * @ x == 'head' ks @
215--
216-- * @ 'True' == 'and' \$ 'zipWith' rel ks ('tail' ks) @
217--
218-- The second condition is requiring consecutive pairs to satsify the given
219-- relation @rel@.
220--
222allChains :: (a -> a -> Bool) -> a -> [a] -> [[a]] 221allChains :: (a -> a -> Bool) -> a -> [a] -> [[a]]
223allChains op x [] = [[x]] 222allChains op x [] = [[x]]
224allChains op x xs | null ts = [[x]] 223allChains op x xs | null ts = [[x]]
225 | otherwise = ts >>= f 224 | otherwise = ts >>= f
226 where 225 where
227 ts = filter ((x `op`) . head . snd) $ comb xs 226 ts = filter ((x `op`) . head . snd) $ comb xs
228 f (as,y:bs) = map (x:) $ allChains op y (as++bs) 227 f (as,y:bs) = map (x:) $ allChains op y (bs++as)
229 228
230-- | These functions are used by 'validate' to determine when a certificate is 229-- | These functions are used by 'validate' to determine when a certificate is
231-- validly issued by another. 230-- validly issued by another.
@@ -234,7 +233,7 @@ data IssuanceTest = IssuanceTest
234 -- ^ This is used to validate a single link in a certificate chain. 233 -- ^ This is used to validate a single link in a certificate chain.
235 , isSignedBy :: SignedCertificate -> PubKey -> Bool 234 , isSignedBy :: SignedCertificate -> PubKey -> Bool
236 -- ^ This is used to check signatures for trust anchor keys that are 235 -- ^ This is used to check signatures for trust anchor keys that are
237 -- supplied via a 'TLSA' record but not otherwise present in the chain. 236 -- supplied via a 'TLSA' record but not otherwise present in the input.
238 } 237 }
239 238
240-- | Use the the given set of 'TLSA' records to validate or paritally validate 239-- | Use the the given set of 'TLSA' records to validate or paritally validate
@@ -303,8 +302,8 @@ validate (IssuanceTest isIssuedBy isSignedBy) rs cert chain
303 r .~ u = certUsage r == u 302 r .~ u = certUsage r == u
304 (daneEEs,rs2) = partition (.~ DomainIssued) rs 303 (daneEEs,rs2) = partition (.~ DomainIssued) rs
305 (daneTAs,rs3) = partition (.~ TrustAnchorAssertion) rs2 304 (daneTAs,rs3) = partition (.~ TrustAnchorAssertion) rs2
306 (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3 305 (pkixEEs,rs4) = partition (.~ AcceptableEE) rs3
307 (pkixTAs,_) = partition (.~ CAConstraint) rs4 306 (pkixTAs,_) = partition (.~ AcceptableCA) rs4
308 307
309pairings :: (a -> b -> Bool) -> [a] -> [b] -> [(a,[b])] 308pairings :: (a -> b -> Bool) -> [a] -> [b] -> [(a,[b])]
310pairings op = loop 309pairings op = loop
@@ -315,39 +314,6 @@ pairings op = loop
315 [] -> (m,[]):loop ms cs 314 [] -> (m,[]):loop ms cs
316 (as,b:bs):_ -> (m,[b]):loop ms (as++bs) 315 (as,b:bs):_ -> (m,[b]):loop ms (as++bs)
317 316
318{-
319validate :: [TLSA] -> SignedCertificate -> [SignedCertificate] -> Validation
320validate rs cert chain
321 | some domainIssued = Passed
322 | null constraints || some passed = TrustAnchors anchors absent
323 | otherwise = Failed constraints
324 where
325 domainIssued = filter (`match` cert) daneEEs
326 (bs,ns) = partition (null . snd) $ pairings match daneTAs (cert:chain)
327 anchors = concatMap snd ns
328 absent = mapMaybe (extractCert . fst) bs
329
330 constraints = pkixEEs ++ pkixTAs
331 passed = passedEEs ++ passedTAs
332 where
333 passedEEs = filter (`match` cert) pkixEEs
334 -- TODO
335 -- These passedTAs are only truly passed if the
336 -- certs that match them are reachable.
337 -- Where a cert is "reachable" if it is the end entity
338 -- cert or if it is the issuer of a reachable cert.
339 passedTAs = filter (`matchAny` (cert:chain)) pkixTAs
340 matchAny t = any (t `match`)
341
342 some = not . null
343
344 r .~ u = certUsage r == u
345 (daneEEs,rs2) = partition (.~ DomainIssued) rs
346 (daneTAs,rs3) = partition (.~ TrustAnchorAssertion) rs2
347 (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3
348 (pkixTAs,_) = partition (.~ CAConstraint) rs4
349-}
350
351certOrKey :: TLSA -> Maybe (Either PubKey SignedCertificate) 317certOrKey :: TLSA -> Maybe (Either PubKey SignedCertificate)
352certOrKey tlsa@(matchingType->Match_Exact) = 318certOrKey tlsa@(matchingType->Match_Exact) =
353 case selector tlsa of 319 case selector tlsa of
@@ -362,6 +328,7 @@ certOrKey tlsa@(matchingType->Match_Exact) =
362 hush (Left _) = Nothing 328 hush (Left _) = Nothing
363 hush (Right a) = Just a 329 hush (Right a) = Just a
364 330
331{-
365extractCert :: TLSA -> Maybe SignedCertificate 332extractCert :: TLSA -> Maybe SignedCertificate
366extractCert tlsa@(matchingType->Match_Exact) = 333extractCert tlsa@(matchingType->Match_Exact) =
367 case selector tlsa of 334 case selector tlsa of
@@ -390,3 +357,8 @@ certificateFromKey key = unsigned cert
390 , certSubjectDN = DistinguishedName [] 357 , certSubjectDN = DistinguishedName []
391 , certExtensions = Extensions Nothing 358 , certExtensions = Extensions Nothing
392 } 359 }
360 unsigned :: (Show a, ASN1Object a, Eq a) => a -> SignedExact a
361 unsigned obj = fst $ objectToSignedExact fakeSign obj
362 where fakeSign = const $ ("", SignatureALG_Unknown [], ())
363-}
364