Rewrite Verifier with Validation

4 files changed, 42 insertions, 100 deletions

diff --git a/default.nix b/default.nix
index d968974..bd725a9 100644
--- a/default.nix
+++ b/default.nix
@@ -1,6 +1,6 @@
 { mkDerivation, attoparsec, base, base64-bytestring, byteable
-, bytestring, cereal, cryptohash, deepseq, hex, QuickCheck, stdenv
-, tasty, tasty-hunit, tasty-quickcheck
+, bytestring, cereal, cryptohash, deepseq, either, hex, QuickCheck
+, stdenv, tasty, tasty-hunit, tasty-quickcheck
 }:
 mkDerivation {
   pname = "hmacaroons";
@@ -8,11 +8,11 @@ mkDerivation {
   src = ./.;
   buildDepends = [
     attoparsec base base64-bytestring byteable bytestring cereal
-    cryptohash deepseq hex
+    cryptohash deepseq either hex
   ];
   testDepends = [
     attoparsec base base64-bytestring byteable bytestring cereal
-    cryptohash hex QuickCheck tasty tasty-hunit tasty-quickcheck
+    cryptohash either hex QuickCheck tasty tasty-hunit tasty-quickcheck
   ];
   homepage = "https://github.com/jtanguy/hmacaroons";
   description = "Haskell implementation of macaroons";
diff --git a/hmacaroons.cabal b/hmacaroons.cabal
index b70a984..3aa338a 100644
--- a/hmacaroons.cabal
+++ b/hmacaroons.cabal
@@ -86,6 +86,7 @@ benchmark bench
                   cereal >= 0.4,
                   cryptohash >=0.11 && <0.12,
                   -- cipher-aes >=0.2 && <0.3,
+                  either >=4.4,
                   hex >= 0.1,
                   deepseq >= 1.1,
                   criterion >= 1.1
@@ -102,6 +103,7 @@ test-suite test
                   byteable >= 0.1 && <0.2,
                   cereal >= 0.4,
                   cryptohash >=0.11 && <0.12,
+                  either >=4.4,
                   hex >= 0.1,
                   tasty >= 0.10,
                   tasty-hunit >= 0.9,
diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs
index 02cb448..713a971 100644
--- a/src/Crypto/Macaroon/Verifier.hs
+++ b/src/Crypto/Macaroon/Verifier.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes        #-}
 {-|
 Module      : Crypto.Macaroon.Verifier
 Copyright   : (c) 2015 Julien Tanguy
@@ -13,79 +13,50 @@ Portability : portable
 
 -}
 module Crypto.Macaroon.Verifier (
-    Verified(..)
-  , CaveatVerifier
-  , (<???>)
+    Verifier
   , verifyMacaroon
   , verifySig
-  , verifyExact
-  , verifyFun
+  -- , verifyExact
+  -- , verifyFun
   , module Data.Attoparsec.ByteString.Char8
   , verifyCavs
 ) where
 
 
 import           Crypto.Hash
+import           Data.Attoparsec.ByteString
+import           Data.Attoparsec.ByteString.Char8
 import           Data.Bool
-import qualified Data.ByteString            as BS
 import           Data.Byteable
+import qualified Data.ByteString                  as BS
+import           Data.Either
+import           Data.Either.Validation
 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
 
+type Verifier = Caveat -> Maybe (Either String Caveat)
 
--- | Opaque datatype for now. Might need more explicit errors
-data Verified = Ok | Failed deriving (Show,Eq)
-
-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 $
+verifySig :: Key -> Macaroon -> Either String Macaroon
+verifySig k m = bool (Left "Signatures do not match") (Right m) $
       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
-
+verifyMacaroon :: Key -> [Verifier] -> Macaroon -> Either String Macaroon
+verifyMacaroon secret verifiers m = verifySig secret m >>= verifyCavs verifiers
 
-verifyCavs :: [CaveatVerifier] -> Macaroon -> Verified
-verifyCavs verifiers m = foldMap (\c -> fromMaybe Failed $ foldMap (($ c) . vFun) verifiers) (caveats m)
+verifyCavs :: [Verifier] -> Macaroon -> Either String Macaroon
+verifyCavs verifiers m = case partitionEithers verifiedCaveats of
+    ([],_) -> Right m
+    (errs,_) -> Left (mconcat errs)
+  where
+    verifiedCaveats = map (\c -> defaultFail c $ foldMap (fmap eitherToValidation . ($c)) verifiers) $ caveats m
+    defaultFail c = maybe (Left ("No validation for this caveat: " ++ show c)) validationToEither
 
-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
+-- TODO: define API
diff --git a/test/Crypto/Macaroon/Verifier/Tests.hs b/test/Crypto/Macaroon/Verifier/Tests.hs
index 101fa26..4a9295f 100644
--- a/test/Crypto/Macaroon/Verifier/Tests.hs
+++ b/test/Crypto/Macaroon/Verifier/Tests.hs
@@ -16,7 +16,8 @@ import Data.List
 import qualified Data.ByteString.Char8 as B8
 import Test.Tasty
 -- import Test.Tasty.HUnit
-import Test.Tasty.QuickCheck
+import Test.Tasty.QuickCheck hiding (Success, Failure)
+import Data.Either
 
 import           Crypto.Macaroon
 import           Crypto.Macaroon.Verifier
@@ -25,7 +26,6 @@ import Crypto.Macaroon.Instances
 
 tests :: TestTree
 tests = testGroup "Crypto.Macaroon.Verifier" [ sigs
-                                             , firstParty
                                              ]
 
 {-
@@ -45,52 +45,21 @@ m2 = addFirstPartyCaveat "test = caveat" m
 m3 :: Macaroon
 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"
+-- exTC = verifyExact "test" "caveat" (many' letter_ascii)
+-- exTZ = verifyExact "test" "bleh" (many' letter_ascii)
+-- exV42 = verifyExact "value" 42 decimal
+-- exV43 = verifyExact "value" 43 decimal
 
-funTCPre = verifyFun "test" ("cav" `isPrefixOf`) (many' letter_ascii) <???> "test startsWith cav"
-funTV43lte = verifyFun "value" (<= 43) decimal <???> "value <= 43"
+-- funTCPre = verifyFun "test" (string "test = " *> many' letter_ascii)
+--                             (\e ->  if "cav" `isPrefixOf` e then Right e else Left "Does not start with cav" )
+-- funTV43lte = verifyFun "value" (string "value = " *> decimal)
+--                                (\v -> if v <= 43 then Right v else Left "Greater than 43")
 
-allvs = [exTC, exTZ, exV42, exV43, funTCPre, funTV43lte]
+-- 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
-            ])
-      ]
-    ]
+sigs = testProperty "Signatures" $ \sm -> verifySig (secret sm) (macaroon sm) == Right (macaroon sm)
+
+-- TODO: Re-do tests