summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-05-20 16:14:18 -0400
committerjoe <joe@jerkface.net>2014-05-20 16:14:18 -0400
commitd9f7c379178c414d06f458d180f05f45929e3581 (patch)
treebf1b3075175c01b128f6f98febb4519e44b01737
parentc4eb57db255580737ed9f75ffcbbc4db7e4b073f (diff)
work in progress on DANE protocol
-rw-r--r--TLSA.hs213
1 files changed, 205 insertions, 8 deletions
diff --git a/TLSA.hs b/TLSA.hs
index 4006286..ecf033c 100644
--- a/TLSA.hs
+++ b/TLSA.hs
@@ -1,4 +1,4 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
2module TLSA 2module TLSA
3 ( TLSA(..) 3 ( TLSA(..)
4 , CertUsage(..) 4 , CertUsage(..)
@@ -7,19 +7,28 @@ module TLSA
7 , fromByteString 7 , fromByteString
8 , toByteString 8 , toByteString
9 , match 9 , match
10 , Validation(..)
11 , validate
12 , validate2
10 ) where 13 ) where
11 14
12import qualified Data.ByteString as BS 15import qualified Data.ByteString as BS
13import qualified Data.ByteString.Lazy as L 16import qualified Data.ByteString.Lazy as L
14import qualified Crypto.Hash.SHA256 as SHA256 17import qualified Crypto.Hash.SHA256 as SHA256
15import qualified Crypto.Hash.SHA512 as SHA512 18import qualified Crypto.Hash.SHA512 as SHA512
16import Data.X509 ( certPubKey, Certificate ) 19import Data.X509 {- ( certPubKey, Certificate(..), SignedCertificate, getCertificate
17import Data.ASN1.Types ( toASN1 ) 20 , getSigned, getSignedData, signedObject, objectToSignedExact
18import Data.ASN1.Encoding ( encodeASN1 ) 21 , SignatureALG(SignatureALG_Unknown), SignedExact
22 , encodeSignedObject, decodeSignedObject ) -}
23import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 )
24import Data.ASN1.Encoding ( encodeASN1, decodeASN1 )
25import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
26
19import Data.ASN1.BinaryEncoding 27import Data.ASN1.BinaryEncoding
20import Control.Applicative 28import Control.Applicative
21import Data.Word 29import Data.Word
22import Data.Maybe 30import Data.Maybe
31import Data.List
23import Data.Monoid 32import Data.Monoid
24 33
25{- INLINE fromWord8 #-} 34{- INLINE fromWord8 #-}
@@ -31,6 +40,8 @@ toWord8 :: Enum a => a -> Word8
31toWord8 = toEnum . fromEnum 40toWord8 = toEnum . fromEnum
32 41
33-- | The Certificate Usage Field as described in RFC 6698, section 2.1.1. 42-- | The Certificate Usage Field as described in RFC 6698, section 2.1.1.
43--
44-- It is used by the 'validate' function in making a 'Validation' decision.
34data CertUsage 45data CertUsage
35 46
36 -- | This usage limits which CA can be used to issue certificates for a 47 -- | This usage limits which CA can be used to issue certificates for a
@@ -149,19 +160,24 @@ toByteString (TLSA cu sel mat dta) = csm <> dta
149-- | Returns 'True' if the given certificate matches the given 'TLSA' object. 160-- | Returns 'True' if the given certificate matches the given 'TLSA' object.
150-- The algorithm for matching depends on the values of 'selector' and 161-- The algorithm for matching depends on the values of 'selector' and
151-- 'matchingType' as described in RFC 6698. 162-- 'matchingType' as described in RFC 6698.
152match :: TLSA -> Certificate -> Bool 163match :: TLSA -> SignedCertificate -> Bool
153match tlsa cert = fromMaybe False $ 164match tlsa cert = fromMaybe False $
154 (== associationData tlsa) <$> (hash <*> material) 165 (== associationData tlsa) <$> (hash <*> material)
155 166
156 where 167 where
157 encode obj = encodeASN1 DER (toASN1 obj []) 168 key = encodeASN1 DER $ toASN1 keyobj []
169 where keyobj = certPubKey $ getCertificate cert
170
171 encoded_cert = L.fromChunks [encodeSignedObject cert]
158 172
173 material :: Maybe L.ByteString
159 material = 174 material =
160 case selector tlsa of 175 case selector tlsa of
161 FullCertificate -> Just $ encode cert 176 FullCertificate -> Just encoded_cert
162 SubjectPublicKeyInfo -> Just $ encode $ certPubKey cert 177 SubjectPublicKeyInfo -> Just key
163 _ -> Nothing 178 _ -> Nothing
164 179
180 hash :: Maybe (L.ByteString -> BS.ByteString)
165 hash = 181 hash =
166 case matchingType tlsa of 182 case matchingType tlsa of
167 Match_Exact -> Just L.toStrict 183 Match_Exact -> Just L.toStrict
@@ -169,3 +185,184 @@ match tlsa cert = fromMaybe False $
169 Match_SHA512 -> Just SHA512.hashlazy 185 Match_SHA512 -> Just SHA512.hashlazy
170 _ -> Nothing 186 _ -> Nothing
171 187
188unsigned :: (Show a, ASN1Object a, Eq a) => a -> SignedExact a
189unsigned obj = fst $ objectToSignedExact fakeSign obj
190 where fakeSign = const $ ("", SignatureALG_Unknown [], ())
191
192data Validation
193 = Failed [TLSA]
194 -- ^ All of the given constraints failed.
195 | TrustAnchors [SignedCertificate] [SignedCertificate]
196 -- ^ Perform PKI validation with the given additional trust anchors. The
197 -- first list are trust anchors that occured in the chain. The second list
198 -- are anchors that did not occur in the chain. If 'certVersion' == (-1)
199 -- for any certificate in the second list, then all fields except
200 -- 'certPubKey' should be ignored.
201 | Passed
202 -- ^ Valid end entity. Do not perform PKI.
203
204
205-- comb [1,2,3] = [([],[1,2,3]),([1],[2,3]),([2,1],[3])]
206comb cs = matchLength cs $ iterate sweepLeft ([],cs)
207 where sweepLeft (xs,y:ys) = (y:xs,ys)
208 matchLength = zipWith (flip const)
209
210-- O(n²) worst case
211-- O(n) best case
212-- op is an antisymmetric operation
213connectedChain op x [] = [x]
214connectedChain op x xs =
215 case filter ((x `op`) . snd) $ comb xs of
216 [] -> [x]
217 (as,y:bs):_ -> x : connectedChain op y (bs++as)
218
219allChains :: (a -> a -> Bool) -> a -> [a] -> [[a]]
220allChains op x [] = [[x]]
221allChains op x xs | null ts = [[x]]
222 | otherwise = ts >>= f
223 where
224 ts = filter ((x `op`) . head . snd) $ comb xs
225 f (as,y:bs) = map (x:) $ allChains op y (as++bs)
226
227-- | > validate2 isIssuedBy isSignedBy rs cert otherCerts
228--
229-- * isIssuedBy - validates one link in a certificate chain
230--
231-- * isSignedBy - True if the certificate is signed by the key
232--
233-- * rs - A set of TLSA records obtained from DNS
234--
235-- * cert - The end entity target cert to verify
236--
237-- * otherCerts - Other relevent certificates
238--
239-- Returns:
240--
241-- * @ Nothing @ - The end entity certificate is valid.
242--
243-- * @ Just chains @ - A set of connected certificate chains.
244-- The certificate is valid if and only if there
245-- exists a chain that contains a CA certificate
246-- that is issued by a trust anchor.
247--
248validate2 :: (SignedCertificate -> SignedCertificate -> Bool)
249 -> (SignedCertificate -> PubKey -> Bool)
250 -> [TLSA] -> SignedCertificate -> [SignedCertificate] -> Maybe [[SignedCertificate]]
251validate2 isIssuedBy isSignedBy rs cert chain
252 | some domainIssued = Nothing
253 | any hasAnchor chains = Nothing
254 | otherwise = Just $ filter satisfiesConstraints chains
255 where
256 domainIssued = filter (`match` cert) daneEEs
257
258 chains = allChains isIssuedBy cert chain
259
260 hasAnchor cs = some anchors
261 || some [ c | c <- cs, cert <- certs, c `isIssuedBy` cert ]
262 || some [ c | c <- cs, key <- keys, c `isSignedBy` key ]
263 where
264 (bs,ns) = partition (null . snd) $ pairings match daneTAs cs
265 anchors = concatMap snd ns
266 absent = mapMaybe (certOrKey . fst) bs
267 certs = mapMaybe rightToMaybe absent
268 keys = mapMaybe leftToMaybe absent
269 rightToMaybe (Right x) = Just x
270 rightToMaybe _ = Nothing
271 leftToMaybe (Left x) = Just x
272 leftToMaybe _ = Nothing
273
274 satisfiesConstraints (c:cs) = any eeSatisfied pkixEEs
275 || any caSatisfied pkixTAs
276 where
277 eeSatisfied = (`match` c)
278 caSatisfied r = any (r `match`) cs
279
280 some = not . null
281
282 r .~ u = certUsage r == u
283 (daneEEs,rs2) = partition (.~ DomainIssued) rs
284 (daneTAs,rs3) = partition (.~ TrustAnchorAssertion) rs2
285 (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3
286 (pkixTAs,_) = partition (.~ CAConstraint) rs4
287
288pairings op = loop
289 where
290 loop [] cs = []
291 loop (m:ms) cs =
292 case filter (op m . head . snd) $ comb cs of
293 [] -> (m,[]):loop ms cs
294 (as,b:bs):_ -> (m,[b]):loop ms (as++bs)
295
296validate :: [TLSA] -> SignedCertificate -> [SignedCertificate] -> Validation
297validate rs cert chain
298 | some domainIssued = Passed
299 | null constraints || some passed = TrustAnchors anchors absent
300 | otherwise = Failed constraints
301 where
302 domainIssued = filter (`match` cert) daneEEs
303 (bs,ns) = partition (null . snd) $ pairings match daneTAs (cert:chain)
304 anchors = concatMap snd ns
305 absent = mapMaybe (extractCert . fst) bs
306
307 constraints = pkixEEs ++ pkixTAs
308 passed = passedEEs ++ passedTAs
309 where
310 passedEEs = filter (`match` cert) pkixEEs
311 -- TODO
312 -- These passedTAs are only truly passed if the
313 -- certs that match them are reachable.
314 -- Where a cert is "reachable" if it is the end entity
315 -- cert or if it is the issuer of a reachable cert.
316 passedTAs = filter (`matchAny` (cert:chain)) pkixTAs
317 matchAny t = any (t `match`)
318
319 some = not . null
320
321 r .~ u = certUsage r == u
322 (daneEEs,rs2) = partition (.~ DomainIssued) rs
323 (daneTAs,rs3) = partition (.~ TrustAnchorAssertion) rs2
324 (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3
325 (pkixTAs,_) = partition (.~ CAConstraint) rs4
326
327certOrKey :: TLSA -> Maybe (Either PubKey SignedCertificate)
328certOrKey tlsa@(matchingType->Match_Exact) =
329 case selector tlsa of
330 FullCertificate -> either (const Nothing)
331 (Just . Right)
332 (decodeSignedObject $ associationData tlsa)
333 SubjectPublicKeyInfo -> do
334 a <- hush $ decodeASN1 DER $ L.fromChunks [associationData tlsa]
335 (key,_) <- hush $ fromASN1 a
336 return $ Left key
337 where
338 hush (Left _) = Nothing
339 hush (Right a) = Just a
340
341extractCert :: TLSA -> Maybe SignedCertificate
342extractCert tlsa@(matchingType->Match_Exact) =
343 case selector tlsa of
344 FullCertificate -> either (const Nothing)
345 Just
346 (decodeSignedObject $ associationData tlsa)
347 SubjectPublicKeyInfo -> do
348 a <- hush $ decodeASN1 DER $ L.fromChunks [associationData tlsa]
349 (key,_) <- hush $ fromASN1 a
350 return $ certificateFromKey key
351 where
352 hush (Left _) = Nothing
353 hush (Right a) = Just a
354extractCert _ = Nothing
355
356certificateFromKey :: PubKey -> SignedCertificate
357certificateFromKey key = unsigned cert
358 where
359 cert = Certificate { certPubKey = key
360 , certVersion = (-1)
361 , certSerial = 0
362 , certSignatureAlg = SignatureALG_Unknown []
363 , certIssuerDN = DistinguishedName []
364 , certValidity = ( posixSecondsToUTCTime (-1/0)
365 , posixSecondsToUTCTime (1/0))
366 , certSubjectDN = DistinguishedName []
367 , certExtensions = Extensions Nothing
368 }