From b1b7214755b48eb2446e6036183e0f65294a3f25 Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 20 May 2014 20:25:13 -0400 Subject: Renamed constraint records to be more clear. --- TLSA.hs | 118 +++++++++++++++++++++++++--------------------------------------- 1 file changed, 45 insertions(+), 73 deletions(-) (limited to 'TLSA.hs') 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 , 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 @@ -44,17 +43,20 @@ toWord8 = toEnum . fromEnum -- 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 - -- given service on a host. PKIX-validated TLS connections for the domain - -- should be considered invalid if the certification path does not include - -- at least one certificate that 'match'es the 'TLSA' record. - = CAConstraint - - -- | This usage limits which end entity certificate can be used by a given - -- service on a host. The TLS connection for the domain should be - -- considered invalid if the end entity certificate does not 'match' the - -- 'TLSA' record. - | ServiceCertificateConstraint + -- | This is usage value 0 in RFC 6698. Any CA certificate that 'match'es + -- the 'TSLA' record is acceptable. If the chain cannot be validated via + -- 'TLSA' records alone (using 'TrustAnchorAssertion' or 'DomainIssued'), + -- and there are any usable 'TLSA' records at all, then the 'validate' + -- function will require at least one acceptable certificate. + = AcceptableCA + + -- | This is usage value 1 in RFC 6698. If the target certificate + -- 'match'es, then it is considered acceptable. If the chain cannot be + -- validated via 'TLSA' records alone (using 'TrustAnchorAssertion' or + -- 'DomainIssued'), and there are any usable 'TLSA' records at all, then + -- the 'validate' function will require at least one acceptable + -- certificate. + | AcceptableEE -- | This usage allows a domain name administrator to specify a new trust -- anchor. This is useful if the domain issues its own certificates under @@ -67,20 +69,20 @@ data CertUsage -- | This usage allows for a domain name administrator to issue -- certificates for a domain without involving a third-party CA. The end -- entity certificate MUST 'match' the 'TLSA' record. Unlike for a - -- 'ServiceCertificateConstraint', PKIX validation should not be performed. + -- 'AcceptableEE', PKIX validation should not be performed. | DomainIssued - | CertUsage Word8 + | CertUsage Word8 -- ^ Unusable. deriving (Eq, Ord, Show, Read) instance Enum CertUsage where - fromEnum CAConstraint = 0 - fromEnum ServiceCertificateConstraint = 1 + fromEnum AcceptableCA = 0 + fromEnum AcceptableEE = 1 fromEnum TrustAnchorAssertion = 2 fromEnum DomainIssued = 3 fromEnum (CertUsage n) = fromEnum n - toEnum 0 = CAConstraint - toEnum 1 = ServiceCertificateConstraint + toEnum 0 = AcceptableCA + toEnum 1 = AcceptableEE toEnum 2 = TrustAnchorAssertion toEnum 3 = DomainIssued toEnum n = CertUsage (toEnum n) @@ -185,24 +187,6 @@ 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 :: [x] -> [([x],[x])] @@ -210,6 +194,7 @@ 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 @@ -218,14 +203,28 @@ connectedChain op x xs = case filter ((x `op`) . snd) $ comb xs of [] -> [x] (as,y:bs):_ -> x : connectedChain op y (bs++as) +-} +-- | > allChains rel x xs +-- +-- Given a relation @rel@, a starting element @x@ and a collection of similarly +-- typed elements @xs@, returns the set of all ordered subsets @ks@ of @x:xs@ +-- such that: +-- +-- * @ x == 'head' ks @ +-- +-- * @ 'True' == 'and' \$ 'zipWith' rel ks ('tail' ks) @ +-- +-- The second condition is requiring consecutive pairs to satsify the given +-- relation @rel@. +-- 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) + f (as,y:bs) = map (x:) $ allChains op y (bs++as) -- | These functions are used by 'validate' to determine when a certificate is -- validly issued by another. @@ -234,7 +233,7 @@ data IssuanceTest = IssuanceTest -- ^ This is used to validate a single link in a certificate chain. , isSignedBy :: SignedCertificate -> PubKey -> Bool -- ^ This is used to check signatures for trust anchor keys that are - -- supplied via a 'TLSA' record but not otherwise present in the chain. + -- supplied via a 'TLSA' record but not otherwise present in the input. } -- | Use the the given set of 'TLSA' records to validate or paritally validate @@ -303,8 +302,8 @@ validate (IssuanceTest isIssuedBy isSignedBy) rs cert chain r .~ u = certUsage r == u (daneEEs,rs2) = partition (.~ DomainIssued) rs (daneTAs,rs3) = partition (.~ TrustAnchorAssertion) rs2 - (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3 - (pkixTAs,_) = partition (.~ CAConstraint) rs4 + (pkixEEs,rs4) = partition (.~ AcceptableEE) rs3 + (pkixTAs,_) = partition (.~ AcceptableCA) rs4 pairings :: (a -> b -> Bool) -> [a] -> [b] -> [(a,[b])] pairings op = loop @@ -315,39 +314,6 @@ pairings op = loop [] -> (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 @@ -362,6 +328,7 @@ certOrKey tlsa@(matchingType->Match_Exact) = hush (Left _) = Nothing hush (Right a) = Just a +{- extractCert :: TLSA -> Maybe SignedCertificate extractCert tlsa@(matchingType->Match_Exact) = case selector tlsa of @@ -390,3 +357,8 @@ certificateFromKey key = unsigned cert , certSubjectDN = DistinguishedName [] , certExtensions = Extensions Nothing } + unsigned :: (Show a, ASN1Object a, Eq a) => a -> SignedExact a + unsigned obj = fst $ objectToSignedExact fakeSign obj + where fakeSign = const $ ("", SignatureALG_Unknown [], ()) +-} + -- cgit v1.2.3