diff options
-rw-r--r-- | TLSA.hs | 118 |
1 files changed, 45 insertions, 73 deletions
@@ -21,7 +21,6 @@ import Data.X509 {- ( certPubKey, Certificate(..), SignedCertificate, ge | |||
21 | , encodeSignedObject, decodeSignedObject ) -} | 21 | , encodeSignedObject, decodeSignedObject ) -} |
22 | import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 ) | 22 | import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 ) |
23 | import Data.ASN1.Encoding ( encodeASN1, decodeASN1 ) | 23 | import Data.ASN1.Encoding ( encodeASN1, decodeASN1 ) |
24 | import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) | ||
25 | 24 | ||
26 | import Data.ASN1.BinaryEncoding | 25 | import Data.ASN1.BinaryEncoding |
27 | import Control.Applicative | 26 | import 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. |
45 | data CertUsage | 44 | data 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 | ||
76 | instance Enum CertUsage where | 78 | instance 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 | ||
188 | unsigned :: (Show a, ASN1Object a, Eq a) => a -> SignedExact a | ||
189 | unsigned obj = fst $ objectToSignedExact fakeSign obj | ||
190 | where fakeSign = const $ ("", SignatureALG_Unknown [], ()) | ||
191 | |||
192 | {- | ||
193 | data 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])] |
208 | comb :: [x] -> [([x],[x])] | 192 | comb :: [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 | -- | ||
222 | allChains :: (a -> a -> Bool) -> a -> [a] -> [[a]] | 221 | allChains :: (a -> a -> Bool) -> a -> [a] -> [[a]] |
223 | allChains op x [] = [[x]] | 222 | allChains op x [] = [[x]] |
224 | allChains op x xs | null ts = [[x]] | 223 | allChains 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 | ||
309 | pairings :: (a -> b -> Bool) -> [a] -> [b] -> [(a,[b])] | 308 | pairings :: (a -> b -> Bool) -> [a] -> [b] -> [(a,[b])] |
310 | pairings op = loop | 309 | pairings 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 | {- | ||
319 | validate :: [TLSA] -> SignedCertificate -> [SignedCertificate] -> Validation | ||
320 | validate 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 | |||
351 | certOrKey :: TLSA -> Maybe (Either PubKey SignedCertificate) | 317 | certOrKey :: TLSA -> Maybe (Either PubKey SignedCertificate) |
352 | certOrKey tlsa@(matchingType->Match_Exact) = | 318 | certOrKey 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 | {- | ||
365 | extractCert :: TLSA -> Maybe SignedCertificate | 332 | extractCert :: TLSA -> Maybe SignedCertificate |
366 | extractCert tlsa@(matchingType->Match_Exact) = | 333 | extractCert 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 | |||