From d9f7c379178c414d06f458d180f05f45929e3581 Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 20 May 2014 16:14:18 -0400 Subject: work in progress on DANE protocol --- TLSA.hs | 213 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 205 insertions(+), 8 deletions(-) (limited to 'TLSA.hs') diff --git a/TLSA.hs b/TLSA.hs index 4006286..ecf033c 100644 --- a/TLSA.hs +++ b/TLSA.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, ViewPatterns #-} module TLSA ( TLSA(..) , CertUsage(..) @@ -7,19 +7,28 @@ module TLSA , fromByteString , toByteString , match + , Validation(..) + , validate + , validate2 ) where import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Hash.SHA512 as SHA512 -import Data.X509 ( certPubKey, Certificate ) -import Data.ASN1.Types ( toASN1 ) -import Data.ASN1.Encoding ( encodeASN1 ) +import Data.X509 {- ( certPubKey, Certificate(..), SignedCertificate, getCertificate + , getSigned, getSignedData, signedObject, objectToSignedExact + , SignatureALG(SignatureALG_Unknown), SignedExact + , encodeSignedObject, decodeSignedObject ) -} +import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 ) +import Data.ASN1.Encoding ( encodeASN1, decodeASN1 ) +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) + import Data.ASN1.BinaryEncoding import Control.Applicative import Data.Word import Data.Maybe +import Data.List import Data.Monoid {- INLINE fromWord8 #-} @@ -31,6 +40,8 @@ toWord8 :: Enum a => a -> Word8 toWord8 = toEnum . fromEnum -- | The Certificate Usage Field as described in RFC 6698, section 2.1.1. +-- +-- It is used by the 'validate' function in making a 'Validation' decision. data CertUsage -- | 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 -- | Returns 'True' if the given certificate matches the given 'TLSA' object. -- The algorithm for matching depends on the values of 'selector' and -- 'matchingType' as described in RFC 6698. -match :: TLSA -> Certificate -> Bool +match :: TLSA -> SignedCertificate -> Bool match tlsa cert = fromMaybe False $ (== associationData tlsa) <$> (hash <*> material) where - encode obj = encodeASN1 DER (toASN1 obj []) + key = encodeASN1 DER $ toASN1 keyobj [] + where keyobj = certPubKey $ getCertificate cert + + encoded_cert = L.fromChunks [encodeSignedObject cert] + material :: Maybe L.ByteString material = case selector tlsa of - FullCertificate -> Just $ encode cert - SubjectPublicKeyInfo -> Just $ encode $ certPubKey cert + FullCertificate -> Just encoded_cert + SubjectPublicKeyInfo -> Just key _ -> Nothing + hash :: Maybe (L.ByteString -> BS.ByteString) hash = case matchingType tlsa of Match_Exact -> Just L.toStrict @@ -169,3 +185,184 @@ match tlsa cert = fromMaybe False $ Match_SHA512 -> Just SHA512.hashlazy _ -> Nothing +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. + | TrustAnchors [SignedCertificate] [SignedCertificate] + -- ^ Perform PKI validation with the given additional trust anchors. The + -- first list are trust anchors that occured in the chain. The second list + -- are anchors that did not occur in the chain. If 'certVersion' == (-1) + -- for any certificate in the second list, then all fields except + -- '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 cs = matchLength cs $ iterate sweepLeft ([],cs) + where sweepLeft (xs,y:ys) = (y:xs,ys) + matchLength = zipWith (flip const) + +-- O(n²) worst case +-- O(n) best case +-- op is an antisymmetric operation +connectedChain op x [] = [x] +connectedChain op x xs = + case filter ((x `op`) . snd) $ comb xs of + [] -> [x] + (as,y:bs):_ -> x : connectedChain op y (bs++as) + +allChains :: (a -> a -> Bool) -> a -> [a] -> [[a]] +allChains op x [] = [[x]] +allChains op x xs | null ts = [[x]] + | otherwise = ts >>= f + where + 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 +-- +-- Returns: +-- +-- * @ Nothing @ - The end entity certificate is valid. +-- +-- * @ 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. +-- +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 + domainIssued = filter (`match` cert) daneEEs + + chains = allChains isIssuedBy cert 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 + 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 + leftToMaybe _ = Nothing + + satisfiesConstraints (c:cs) = any eeSatisfied pkixEEs + || any caSatisfied pkixTAs + where + eeSatisfied = (`match` c) + caSatisfied r = any (r `match`) cs + + some = not . null + + r .~ u = certUsage r == u + (daneEEs,rs2) = partition (.~ DomainIssued) rs + (daneTAs,rs3) = partition (.~ TrustAnchorAssertion) rs2 + (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3 + (pkixTAs,_) = partition (.~ CAConstraint) rs4 + +pairings op = loop + where + loop [] cs = [] + loop (m:ms) cs = + case filter (op m . head . snd) $ comb cs of + [] -> (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 + | null constraints || some passed = TrustAnchors anchors absent + | otherwise = Failed constraints + where + domainIssued = filter (`match` cert) daneEEs + (bs,ns) = partition (null . snd) $ pairings match daneTAs (cert:chain) + anchors = concatMap snd ns + absent = mapMaybe (extractCert . fst) bs + + constraints = pkixEEs ++ pkixTAs + passed = passedEEs ++ passedTAs + where + passedEEs = filter (`match` cert) pkixEEs + -- TODO + -- These passedTAs are only truly passed if the + -- certs that match them are reachable. + -- Where a cert is "reachable" if it is the end entity + -- cert or if it is the issuer of a reachable cert. + passedTAs = filter (`matchAny` (cert:chain)) pkixTAs + matchAny t = any (t `match`) + + some = not . null + + r .~ u = certUsage r == u + (daneEEs,rs2) = partition (.~ DomainIssued) rs + (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) = + case selector tlsa of + FullCertificate -> either (const Nothing) + (Just . Right) + (decodeSignedObject $ associationData tlsa) + SubjectPublicKeyInfo -> do + a <- hush $ decodeASN1 DER $ L.fromChunks [associationData tlsa] + (key,_) <- hush $ fromASN1 a + return $ Left key + where + hush (Left _) = Nothing + hush (Right a) = Just a + +extractCert :: TLSA -> Maybe SignedCertificate +extractCert tlsa@(matchingType->Match_Exact) = + case selector tlsa of + FullCertificate -> either (const Nothing) + Just + (decodeSignedObject $ associationData tlsa) + SubjectPublicKeyInfo -> do + a <- hush $ decodeASN1 DER $ L.fromChunks [associationData tlsa] + (key,_) <- hush $ fromASN1 a + return $ certificateFromKey key + where + hush (Left _) = Nothing + hush (Right a) = Just a +extractCert _ = Nothing + +certificateFromKey :: PubKey -> SignedCertificate +certificateFromKey key = unsigned cert + where + cert = Certificate { certPubKey = key + , certVersion = (-1) + , certSerial = 0 + , certSignatureAlg = SignatureALG_Unknown [] + , certIssuerDN = DistinguishedName [] + , certValidity = ( posixSecondsToUTCTime (-1/0) + , posixSecondsToUTCTime (1/0)) + , certSubjectDN = DistinguishedName [] + , certExtensions = Extensions Nothing + } -- cgit v1.2.3