Add basic exact caveat verifiers

Need more tests

Touching #2 Verify first party caveats

2 files changed, 69 insertions, 10 deletions

diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs
index e257f5f..cb64c9d 100644
--- a/src/Crypto/Macaroon/Verifier.hs
+++ b/src/Crypto/Macaroon/Verifier.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-|
 Module      : Crypto.Macaroon.Verifier
 Copyright   : (c) 2015 Julien Tanguy
@@ -11,7 +12,14 @@ Portability : portable
 
 
 -}
-module Crypto.Macaroon.Verifier where
+module Crypto.Macaroon.Verifier (
+    Verified(..)
+  , verifySig
+  , verifyExact
+  , verifyCavs
+  -- , module Data.Attoparsec.ByteString
+  , module Data.Attoparsec.ByteString.Char8
+) where
 
 
 import           Crypto.Hash
@@ -19,16 +27,47 @@ import           Data.Bool
 import qualified Data.ByteString            as BS
 import           Data.Byteable
 import           Data.Foldable
+import           Data.Maybe
+import Data.Attoparsec.ByteString
+import Data.Attoparsec.ByteString.Char8
 
 import           Crypto.Macaroon.Internal
 
 
 -- | Opaque datatype for now. Might need more explicit errors
-data VResult = VSuccess | VFailure deriving (Show,Eq)
+data Verified = Ok | Failed deriving (Show,Eq)
 
-verifySig :: Key -> Macaroon -> VResult
-verifySig k m = bool VFailure VSuccess $
+instance Monoid Verified where
+  mempty = Ok
+  mappend Ok Ok = Ok
+  mappend _ _ = Failed
+
+
+type CaveatVerifier = Caveat -> Maybe Verified
+
+verifySig :: Key -> Macaroon -> Verified
+verifySig k m = bool Failed Ok $
       signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m)
   where
     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)
+
+verifyExact :: (Show a, Eq a) => Key -> a -> Parser a -> Caveat -> Maybe Verified
+verifyExact key expected parser cav = if key `BS.isPrefixOf` cid cav then
+        case parseOnly kvparser (cid cav) of
+          Right v -> verify <$> Just v
+          Left _ -> Just Failed
+        else Nothing
+  where
+    kvparser = do
+      key <- string key
+      skipSpace
+      string "="
+      skipSpace
+      parser
+
+      -- *> skipSpace *> string "=" *> skipSpace *> parser <* endOfInput
+    verify a = bool Failed Ok (a == expected)
diff --git a/test/Crypto/Macaroon/Verifier/Tests.hs b/test/Crypto/Macaroon/Verifier/Tests.hs
index f87f192..37d0230 100644
--- a/test/Crypto/Macaroon/Verifier/Tests.hs
+++ b/test/Crypto/Macaroon/Verifier/Tests.hs
@@ -24,6 +24,7 @@ import Crypto.Macaroon.Instances
 
 tests :: TestTree
 tests = testGroup "Crypto.Macaroon.Verifier" [ sigs
+                                             , exactCavs
                                              ]
 
 {-
@@ -41,7 +42,14 @@ m2 :: Macaroon
 m2 = addFirstPartyCaveat "test = caveat" m
 
 m3 :: Macaroon
-m3 = addFirstPartyCaveat "test = acaveat" m
+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
+               ]
 
 {-
  - Tests
@@ -54,14 +62,26 @@ sigs = testGroup "Signatures" [ basic
 basic = testGroup "Basic Macaroon" [ none , sigQC ]
 
 none = testCase "No caveat" $
-    VSuccess @=? verifySig sec m
+    Ok @=? verifySig sec m
 
 sigQC = testProperty "Random" $
-    \sm -> verifySig (secret sm) (macaroon sm) == VSuccess
+    \sm -> verifySig (secret sm) (macaroon sm) == Ok
 
 one = testCase "Macaroon with one caveat" $
-    VSuccess @=? verifySig sec m2
+    Ok @=? verifySig sec m2
 
 two = testCase "Macaroon with two caveats" $
-    VSuccess @=? verifySig sec m3
-
+    Ok @=? verifySig sec m3
+
+exactCavs = testGroup "Exact Caveats" [ zero', one', two' , one'', two'']
+
+zero' = testCase "Zero caveat win" $
+    Ok @=? verifyCavs exVerifiers m
+one' = testCase "One caveat win" $
+    Ok @=? verifyCavs exVerifiers m2
+one'' = testCase "Ignoring non-relevant" $
+    Ok @=? verifyCavs exVerifiers' m2
+two' = testCase "Two caveat win" $
+    Ok @=? verifyCavs exVerifiers m3
+two'' = testCase "Two caveat fail" $
+    Failed @=? verifyCavs exVerifiers' m3