Fix caveat verification

QuickCheck properties > HUnit tests

2 files changed, 37 insertions, 43 deletions

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
-  ]
+    ]