1 files changed, 63 insertions, 40 deletions

diff --git a/TLSA.hs b/TLSA.hs
index ecf033c..7fb66dc 100644
--- a/TLSA.hs
+++ b/TLSA.hs
@@ -7,9 +7,8 @@ module TLSA
     , fromByteString
     , toByteString
     , match
-    , Validation(..)
+    , IssuanceTest(..)
     , validate
-    , validate2
     ) where
 
 import qualified Data.ByteString as BS
@@ -30,6 +29,7 @@ import Data.Word
 import Data.Maybe
 import Data.List
 import Data.Monoid
+import Data.Array.IArray
 
 {- INLINE fromWord8 #-}
 fromWord8 :: Enum a => Word8 -> a
@@ -189,6 +189,7 @@ 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.
@@ -200,9 +201,11 @@ data Validation
     -- '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])]
 comb cs = matchLength cs $ iterate sweepLeft ([],cs)
     where sweepLeft (xs,y:ys) = (y:xs,ys)
           matchLength = zipWith (flip const)
@@ -224,48 +227,67 @@ allChains op x xs | null ts   = [[x]]
     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
+-- | These functions are used by 'validate' to determine when a certificate is
+-- validly issued by another.
+data IssuanceTest = IssuanceTest 
+    { isIssuedBy :: SignedCertificate -> SignedCertificate -> Bool
+    -- ^ 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.
+    }
+
+-- | Use the the given set of 'TLSA' records to validate, or paritally validate
+-- a certificate, given a list of other probably relevent certificates. Results
+-- are interpreted as follows:
 --
---  Returns:
+--   [@ Nothing   @] The certificate passed validation.
 --
---   * @ Nothing @ - The end entity certificate is valid.
+--   [@ Just \[\] @] Failed validation.
 --
---   * @ 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.
+--   [@ Just xss  @] A set of certificate issued-by chains.  If you trust any
+--                   certificate in any of these chains, you may consider the
+--                   certificate validated.  Otherwise, it failed validation.  
 --
-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
+validate :: IssuanceTest -> [TLSA] -> SignedCertificate -> [SignedCertificate]
+         -> Maybe [[SignedCertificate]]
+validate (IssuanceTest isIssuedBy isSignedBy) rs cert chain
+    | not (null domainIssued) = Nothing
+    | any hasAnchor chains    = Nothing
+    | otherwise = Just $ (certv !) .: filter satisfiesConstraints chains
+ where
     domainIssued = filter (`match` cert) daneEEs
 
-    chains = allChains isIssuedBy cert chain
+    threshold = length 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
+    len = threshold + length anchor_certs
+
+    certv :: Array Int SignedCertificate
+    certv = listArray (0,len) $ cert:chain ++ anchor_certs
+
+    (.:) = fmap . fmap
+
+    a .<+ b  = (certv ! a)  `isIssuedBy` (certv ! b)
+
+    a .<- b = (certv ! a) `isSignedBy` b
+
+    isAnchor n = or [ n > threshold
+                    , n `elem` anchors
+                    , any (n .<-) anchor_keys ]
+
+    chains = allChains (.<+) 0 [1..len]
+
+    hasAnchor = any isAnchor
+
+    ( anchor_certs, anchor_keys, anchors )
+         = ( mapMaybe rightToMaybe absent
+           , mapMaybe leftToMaybe  absent
+           , fmap fst $ ns >>= snd )
+      where
+        (bs,ns) = partition (null . snd)
+                    $ pairings (\r (_,c) -> match r c) daneTAs
+                    $ zip [0..] (cert:chain)
         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
@@ -274,10 +296,8 @@ validate2 isIssuedBy isSignedBy rs cert chain
     satisfiesConstraints (c:cs) = any eeSatisfied pkixEEs
                                   || any caSatisfied pkixTAs
      where
-        eeSatisfied = (`match` c)
-        caSatisfied r = any (r `match`) cs
-
-    some = not . null
+        eeSatisfied = (`match` (certv ! c))
+        caSatisfied r = any ((r `match`) . (certv !)) cs
 
     r .~ u = certUsage r == u
     (daneEEs,rs2) = partition (.~ DomainIssued)                 rs
@@ -285,6 +305,7 @@ validate2 isIssuedBy isSignedBy rs cert chain
     (pkixEEs,rs4) = partition (.~ ServiceCertificateConstraint) rs3
     (pkixTAs,_)   = partition (.~ CAConstraint)                 rs4
 
+pairings :: (a -> b -> Bool) -> [a] -> [b] -> [(a,[b])]
 pairings op = loop
      where
         loop []     cs = []
@@ -293,6 +314,7 @@ 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
@@ -323,6 +345,7 @@ validate rs cert chain
     (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) =