Add basic macaroon verification

5 files changed, 141 insertions, 28 deletions

diff --git a/src/Crypto/Macaroon/Internal.hs b/src/Crypto/Macaroon/Internal.hs
index 116f5ed..2f56512 100644
--- a/src/Crypto/Macaroon/Internal.hs
+++ b/src/Crypto/Macaroon/Internal.hs
@@ -58,7 +58,7 @@ instance Show Macaroon where
     show (MkMacaroon l i c s) = intercalate "\n" [
                       "location " ++ B8.unpack l
                     , "identifier " ++ B8.unpack i
-                    , concatMap show c
+                    , intercalate "\n" (map show c)
                     , "signature " ++ B8.unpack (hex s)
                     ]
 
diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs
index 0d1636c..02cb448 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,17 @@ Portability : portable
 
 
 -}
-module Crypto.Macaroon.Verifier where
+module Crypto.Macaroon.Verifier (
+    Verified(..)
+  , CaveatVerifier
+  , (<???>)
+  , verifyMacaroon
+  , verifySig
+  , verifyExact
+  , verifyFun
+  , module Data.Attoparsec.ByteString.Char8
+  , verifyCavs
+) where
 
 
 import           Crypto.Hash
@@ -19,16 +30,62 @@ 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
 
 import           Crypto.Macaroon.Internal
 
 
 -- | Opaque datatype for now. Might need more explicit errors
-data Result = Success | Failure deriving (Show,Eq)
+data Verified = Ok | Failed deriving (Show,Eq)
 
-verifySig :: Key -> Macaroon -> Result
-verifySig k m = bool Failure Success $
+instance Monoid Verified where
+  mempty = Ok
+  mappend Ok Ok = Ok
+  mappend _ _ = Failed
+
+
+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 $
       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)
+
+verifyMacaroon :: Key -> [CaveatVerifier] -> Macaroon -> Verified
+verifyMacaroon secret verifiers m = verifySig secret m `mappend` verifyCavs verifiers 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 ==)
+
+verifyFun :: Key -> (a -> Bool) -> Parser a -> Caveat -> Maybe Verified
+verifyFun key f parser cav = if key `BS.isPrefixOf` cid cav then
+        case parseOnly kvparser (cid cav) of
+          Right v -> (bool Failed Ok . f) <$> Just v
+          Left _ -> Just Failed
+        else Nothing
+  where
+    kvparser = do
+      key <- string key
+      skipSpace
+      string "="
+      skipSpace
+      parser <* endOfInput
diff --git a/test/Crypto/Macaroon/Instances.hs b/test/Crypto/Macaroon/Instances.hs
index 4e2f39f..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
@@ -48,6 +55,16 @@ newtype Identifier = Identifier { unIdent :: BS.ByteString } deriving (Show)
 instance Arbitrary Identifier where
     arbitrary = Identifier . B8.pack <$>(scale (*3) . listOf1 . elements $ ['a'..'z'])
 
+newtype EquationLike = EquationLike { unEqlike :: BS.ByteString } deriving (Show)
+
+instance Arbitrary EquationLike where
+    arbitrary = do
+        keylen <- choose (3,8)
+        key <- B8.pack <$> vectorOf keylen (elements ['a'..'z'])
+        val <- B8.pack <$> (scale (*3) . listOf1 . elements $ ['a'..'z'])
+        return $ EquationLike (BS.concat [ key, " = ", val])
+
+
 data SimpleMac = SimpleMac { secret :: BS.ByteString, macaroon :: Macaroon } deriving Show
 
 instance Arbitrary SimpleMac where
@@ -55,6 +72,8 @@ instance Arbitrary SimpleMac where
         secret <- unSecret <$> arbitrary
         location <- unUrl <$> arbitrary
         ident <- unIdent <$> arbitrary
-        return $ SimpleMac secret (create secret ident location)
+        fpcavs <- listOf arbitrary
+        let mac = foldl (flip addFirstPartyCaveat) (create secret ident location) (map unEqlike fpcavs)
+        return $ SimpleMac secret mac
 
 
diff --git a/test/Crypto/Macaroon/Serializer/Base64/Tests.hs b/test/Crypto/Macaroon/Serializer/Base64/Tests.hs
index 19084af..ea3bed9 100644
--- a/test/Crypto/Macaroon/Serializer/Base64/Tests.hs
+++ b/test/Crypto/Macaroon/Serializer/Base64/Tests.hs
@@ -30,7 +30,7 @@ tests = testGroup "Crypto.Macaroon.Serializer.Base64" [ basic
                                                       ]
 
 basicQC = testProperty "Reversibility" $
-    forAll (macaroon <$> arbitrary) (\m -> deserialize (serialize m) == Right m)
+    \sm -> deserialize (serialize (macaroon sm)) == Right (macaroon sm)
 
 m :: Macaroon
 m = create secret key loc
diff --git a/test/Crypto/Macaroon/Verifier/Tests.hs b/test/Crypto/Macaroon/Verifier/Tests.hs
index 92a8a21..101fa26 100644
--- a/test/Crypto/Macaroon/Verifier/Tests.hs
+++ b/test/Crypto/Macaroon/Verifier/Tests.hs
@@ -12,9 +12,11 @@ This test suite is based on the pymacaroons test suite:
 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
 import           Crypto.Macaroon.Verifier
@@ -23,8 +25,12 @@ import Crypto.Macaroon.Instances
 
 tests :: TestTree
 tests = testGroup "Crypto.Macaroon.Verifier" [ sigs
+                                             , firstParty
                                              ]
 
+{-
+ - Test fixtures
+ -}
 sec = B8.pack "this is our super secret key; only we should know it"
 
 m :: Macaroon
@@ -37,23 +43,54 @@ m2 :: Macaroon
 m2 = addFirstPartyCaveat "test = caveat" m
 
 m3 :: Macaroon
-m3 = addFirstPartyCaveat "test = acaveat" m
-
-sigs = testGroup "Signatures" [ basic
-                              , minted
-                              ]
-
-basic = testCase "Basic Macaroon Signature" $
-    Success @=? verifySig sec m
-
-
-minted :: TestTree
-minted = testGroup "Macaroon with first party caveats" [ one
-                                                       , two
-                                                       ]
-one = testCase "One caveat" $
-    Success @=? verifySig sec m2
-
-two = testCase "Two caveats" $
-    Success @=? verifySig sec m3
-
+m3 = addFirstPartyCaveat "value = 42" m2
+
+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 = 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
+            ])
+      ]
+    , testGroup "Pure verifiers with sig" [
+        testProperty "Zero caveat" $
+                forAll (sublistOf allvs) (\vs -> Ok == verifyMacaroon sec vs m)
+      , testProperty "One caveat" $
+          forAll (sublistOf allvs) (\vs -> disjoin [
+              Ok == verifyMacaroon sec vs m2 .&&. any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs)
+            , Failed === verifyMacaroon sec vs m2
+            ])
+      , testProperty "Two Exact" $
+          forAll (sublistOf allvs) (\vs -> disjoin [
+              Ok == verifyMacaroon sec vs m3 .&&.
+                any (`elem` vs) [exTC,funTCPre] .&&.  (exTZ `notElem` vs) .&&.
+                any (`elem` vs) [exV42,funTV43lte] .&&.  (exV43 `notElem` vs)
+            , Failed === verifyMacaroon sec vs m3
+            ])
+      ]
+    ]