Renamed constraint records to be more clear.

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
                           , 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 [], ())
+-}
+