Fix caveat verification

QuickCheck properties > HUnit tests

3 files changed, 53 insertions, 46 deletions

diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs
index 012d156..4eedff5 100644
--- a/src/Crypto/Macaroon/Verifier.hs
+++ b/src/Crypto/Macaroon/Verifier.hs
@@ -14,6 +14,8 @@ Portability : portable
 -}
 module Crypto.Macaroon.Verifier (
     Verified(..)
+  , CaveatVerifier(..)
+  , (<???>)
   , verifySig
   , verifyExact
   , verifyFun
@@ -28,7 +30,9 @@ import           Data.Bool
 import qualified Data.ByteString            as BS
 import           Data.Byteable
 import           Data.Foldable
+import           Data.Function
 import           Data.Maybe
+import           Data.Traversable
 import Data.Attoparsec.ByteString
 import Data.Attoparsec.ByteString.Char8
 
@@ -44,7 +48,16 @@ instance Monoid Verified where
   mappend _ _ = Failed
 
 
-type CaveatVerifier = Caveat -> Maybe Verified
+data CaveatVerifier = CV { vFun :: Caveat -> Maybe Verified , helpText :: String}
+
+instance Eq CaveatVerifier where
+  (==) = (==) `on` helpText
+
+instance Show CaveatVerifier where
+    show = helpText
+
+(<???>) :: (Caveat -> Maybe Verified) -> String -> CaveatVerifier
+f <???> t = CV f t
 
 verifySig :: Key -> Macaroon -> Verified
 verifySig k m = bool Failed Ok $
@@ -53,8 +66,8 @@ verifySig k m = bool Failed Ok $
     hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256)
     derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256)
 
-verifyCavs :: [Caveat -> Maybe Verified] -> Macaroon -> Verified
-verifyCavs verifiers m = mconcat $ map (\c -> mconcat . catMaybes $ map ($ c) verifiers) (caveats m)
+verifyCavs :: [CaveatVerifier] -> Macaroon -> Verified
+verifyCavs verifiers m = foldMap (\c -> fromMaybe Failed $ foldMap (($ c) . vFun) verifiers) (caveats m)
 
 verifyExact :: (Eq a) => Key -> a -> Parser a -> Caveat -> Maybe Verified
 verifyExact k expected = verifyFun k (expected ==)
diff --git a/test/Crypto/Macaroon/Instances.hs b/test/Crypto/Macaroon/Instances.hs
index 17044a0..c82bbd3 100644
--- a/test/Crypto/Macaroon/Instances.hs
+++ b/test/Crypto/Macaroon/Instances.hs
@@ -26,9 +26,16 @@ import           Crypto.Macaroon
 
 -- | Adjust the size parameter, by transforming it with the given
 -- function.
+-- Copied over from QuickCheck 2.8
 scale :: (Int -> Int) -> Gen a -> Gen a
 scale f g = sized (\n -> resize (f n) g)
 
+
+-- | Generates a random subsequence of the given list.
+-- Copied over from QuickCheck 2.8
+sublistOf :: [a] -> Gen [a]
+sublistOf = filterM (\_ -> choose (False, True))
+
 newtype Url = Url { unUrl :: BS.ByteString } deriving (Show)
 
 instance Arbitrary Url where
diff --git a/test/Crypto/Macaroon/Verifier/Tests.hs b/test/Crypto/Macaroon/Verifier/Tests.hs
index 54c8db1..5f09bca 100644
--- a/test/Crypto/Macaroon/Verifier/Tests.hs
+++ b/test/Crypto/Macaroon/Verifier/Tests.hs
@@ -15,7 +15,7 @@ module Crypto.Macaroon.Verifier.Tests where
 import Data.List
 import qualified Data.ByteString.Char8 as B8
 import Test.Tasty
-import Test.Tasty.HUnit
+-- import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
 
 import           Crypto.Macaroon
@@ -25,7 +25,7 @@ import Crypto.Macaroon.Instances
 
 tests :: TestTree
 tests = testGroup "Crypto.Macaroon.Verifier" [ sigs
-                                             , exactCavs
+                                             , firstParty
                                              ]
 
 {-
@@ -45,49 +45,36 @@ m2 = addFirstPartyCaveat "test = caveat" m
 m3 :: Macaroon
 m3 = addFirstPartyCaveat "value = 42" m2
 
-exVerifiers = [ verifyExact "test" "caveat" (many' letter_ascii)
-              , verifyExact "value" 42 decimal
-              ]
-exVerifiers' = [ verifyExact "test" "caveat" (many' letter_ascii)
-               , verifyExact "value" 43 decimal
-               ]
-funVerifiers = [ verifyFun "test" ("cav" `isPrefixOf`) (many' letter_ascii)
-               , verifyFun "value" (<= 43) decimal
-               ]
+exTC = verifyExact "test" "caveat" (many' letter_ascii) <???> "test = caveat"
+exTZ = verifyExact "test" "bleh" (many' letter_ascii) <???> "test = bleh"
+exV42 = verifyExact "value" 42 decimal <???> "value = 42"
+exV43 = verifyExact "value" 43 decimal <???> "value = 43"
+
+funTCPre = verifyFun "test" ("cav" `isPrefixOf`) (many' letter_ascii) <???> "test startsWith cav"
+funTV43lte = verifyFun "value" (<= 43) decimal <???> "value <= 43"
+
+allvs = [exTC, exTZ, exV42, exV43, funTCPre, funTV43lte]
 
 {-
  - Tests
  -}
-sigs = testGroup "Signatures" [ basic
-                              , one
-                              , two
-                              ]
-
-basic = testGroup "Basic Macaroon" [ none , sigQC ]
-
-none = testCase "No caveat" $
-    Ok @=? verifySig sec m
-
-sigQC = testProperty "Random" $
-    \sm -> verifySig (secret sm) (macaroon sm) == Ok
-
-one = testCase "Macaroon with one caveat" $
-    Ok @=? verifySig sec m2
-
-two = testCase "Macaroon with two caveats" $
-    Ok @=? verifySig sec m3
-
-exactCavs = testGroup "Exact Caveats" [
-    testGroup "Ignoring non-relevant" [
-        testCase "Zero caveat" $ Ok @=? verifyCavs exVerifiers m
-      , testCase "One caveat" $ Ok @=? verifyCavs exVerifiers' m2
+sigs = testProperty "Signatures" $ \sm -> verifySig (secret sm) (macaroon sm) == Ok
+
+firstParty = testGroup "First party caveats" [
+    testGroup "Pure verifiers" [ 
+        testProperty "Zero caveat" $
+                forAll (sublistOf allvs) (\vs -> Ok == verifyCavs vs m)
+      , testProperty "One caveat" $
+          forAll (sublistOf allvs) (\vs -> disjoin [
+              Ok == verifyCavs vs m2 .&&. any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs)
+            , Failed === verifyCavs vs m2
+            ])
+      , testProperty "Two Exact" $
+          forAll (sublistOf allvs) (\vs -> disjoin [
+              Ok == verifyCavs vs m3 .&&.
+                any (`elem` vs) [exTC,funTCPre] .&&.  (exTZ `notElem` vs) .&&.
+                any (`elem` vs) [exV42,funTV43lte] .&&.  (exV43 `notElem` vs)
+            , Failed === verifyCavs vs m3
+            ])
       ]
-  , testCase "One caveat win" $ Ok @=? verifyCavs exVerifiers m2
-  , testCase "Two caveat win" $ Ok @=? verifyCavs exVerifiers m3
-  , testCase "Two caveat fail" $ Failed @=? verifyCavs exVerifiers' m3
-  ]
-
-funCavs = testGroup "Function Caveats" [
-    testCase "One caveat win" $ Ok @=? verifyCavs funVerifiers m2
-  , testCase "Two caveat win" $ Ok @=? verifyCavs funVerifiers m3
-  ]
+    ]