Basic validation functions

Still needs testing

[ci skip]

6 files changed, 165 insertions, 40 deletions

diff --git a/default.nix b/default.nix
index bd725a9..b1404ef 100644
--- a/default.nix
+++ b/default.nix
@@ -1,14 +1,14 @@
 { mkDerivation, attoparsec, base, base64-bytestring, byteable
 , bytestring, cereal, cryptohash, deepseq, either, hex, QuickCheck
-, stdenv, tasty, tasty-hunit, tasty-quickcheck
+, stdenv, tasty, tasty-hunit, tasty-quickcheck, transformers
 }:
 mkDerivation {
   pname = "hmacaroons";
-  version = "0.1.0.0";
+  version = "0.2.0.0";
   src = ./.;
   buildDepends = [
     attoparsec base base64-bytestring byteable bytestring cereal
-    cryptohash deepseq either hex
+    cryptohash deepseq either hex transformers
   ];
   testDepends = [
     attoparsec base base64-bytestring byteable bytestring cereal
diff --git a/hmacaroons.cabal b/hmacaroons.cabal
index 3aa338a..7b5a0dd 100644
--- a/hmacaroons.cabal
+++ b/hmacaroons.cabal
@@ -1,5 +1,5 @@
 name:                hmacaroons
-version:             0.1.0.0
+version:             0.2.0.0
 synopsis:            Haskell implementation of macaroons
 description:
   = Macaroons: Pure haskell implementation of macaroons
@@ -60,12 +60,14 @@ library
   other-modules:       Crypto.Macaroon.Internal
   build-depends:  base >=4 && < 5,
                   attoparsec >=0.12,
+                  transformers >= 0.4,
                   bytestring >=0.10,
                   base64-bytestring >= 1.0,
                   byteable >= 0.1 && <0.2,
                   cereal >= 0.4,
                   cryptohash >=0.11 && <0.12,
                   either >=4.4,
+                  -- nonce,
                   -- cipher-aes >=0.2 && <0.3,
                   deepseq >= 1.1,
                   hex >= 0.1
diff --git a/shell.nix b/shell.nix
index 07952fc..3846dd5 100644
--- a/shell.nix
+++ b/shell.nix
@@ -1,5 +1,5 @@
-with (import <nixpkgs> {}).pkgs;
-let hspkgs = haskell-ng.packages.ghc7101.override {
+{ pkgs ? import <nixpkgs> {}, compiler ? "ghc7101" }:
+let hspkgs = pkgs.haskell.packages.${compiler}.override {
      overrides = self: super: {
        hmacaroons = self.callPackage ./. {};
       };
diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs
index 713a971..7d5f094 100644
--- a/src/Crypto/Macaroon/Verifier.hs
+++ b/src/Crypto/Macaroon/Verifier.hs
@@ -1,5 +1,8 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-|
 Module      : Crypto.Macaroon.Verifier
 Copyright   : (c) 2015 Julien Tanguy
@@ -13,50 +16,60 @@ Portability : portable
 
 -}
 module Crypto.Macaroon.Verifier (
-    Verifier
-  , verifyMacaroon
-  , verifySig
-  -- , verifyExact
-  -- , verifyFun
-  , module Data.Attoparsec.ByteString.Char8
-  , verifyCavs
+    verify
+  , ValidationError(ValidatorError, ParseError)
+  -- , (.<), (.<=), (.==), (.>), (.>=)
+  -- , module Data.Attoparsec.ByteString.Char8
 ) where
 
 
-import           Crypto.Hash
+import           Control.Monad
+import           Control.Monad.IO.Class
 import           Data.Attoparsec.ByteString
 import           Data.Attoparsec.ByteString.Char8
 import           Data.Bool
-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.Either.Combinators
 
 import           Crypto.Macaroon.Internal
+import           Crypto.Macaroon.Verifier.Internal
 
-type Verifier = Caveat -> Maybe (Either String Caveat)
 
-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 -> [Verifier] -> Macaroon -> Either String Macaroon
-verifyMacaroon secret verifiers m = verifySig secret m >>= verifyCavs verifiers
 
-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
+-- (.<) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- (.<) = verifyOpBool "Greater or equal" (<) "<"
+
+-- (.<=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- (.<=) = verifyOpBool "Strictly greater" (<=) "<="
+
+-- (.==) :: (MonadIO m, Eq a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- (.==) = verifyOpBool "Not equal" (==) "="
+
+-- (.>) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- (.>) = verifyOpBool "Less or equal" (>) ">"
+
+-- (.>=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- (.>=) = verifyOpBool "Strictly less" (>=) ">="
 
 
--- TODO: define API
+verify :: MonadIO m => Key -> [Caveat -> m (Maybe (Either ValidationError Caveat))] -> Macaroon -> m (Either ValidationError Macaroon)
+verify secret verifiers m = join <$> forM (verifySig secret m) (verifyCavs verifiers)
+
+
+-- verifyOpBool :: MonadIO m => String -> Parser a -> (a -> a -> Bool) -> BS.ByteString -> Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- verifyOpBool err p f op k val = verifyParser k valueParser $ \s -> do
+--     expected <- val
+--     return $ bool (Left $ ValidatorError err) (Right Win) =<< f expected <$> mapLeft ParseError (parseOnly p s)
+--   where
+--     valueParser = string op *> skipSpace *> takeByteString
+
+verifyParser :: (MonadIO m) => Key -> Parser a -> (a -> m (Either ValidationError Win)) -> Caveat -> m (Maybe (Either ValidationError Caveat))
+verifyParser k p f c = case parseOnly keyParser . cid $ c of
+    Left _ -> return Nothing
+    Right bs -> Just <$> case parseOnly p bs of
+      Left err -> return $ Left $ ParseError err
+      Right a -> fmap (const c) <$> f a
+  where
+    keyParser = string k *> skipSpace *> takeByteString
+
diff --git a/src/Crypto/Macaroon/Verifier/Internal.hs b/src/Crypto/Macaroon/Verifier/Internal.hs
new file mode 100644
index 0000000..63d826d
--- /dev/null
+++ b/src/Crypto/Macaroon/Verifier/Internal.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE RankNTypes           #-}
+{-|
+Module      : Crypto.Macaroon.Verifier.Internal
+Copyright   : (c) 2015 Julien Tanguy
+License     : BSD3
+
+Maintainer  : julien.tanguy@jhome.fr
+Stability   : experimental
+Portability : portable
+
+
+
+-}
+module Crypto.Macaroon.Verifier.Internal where
+
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Crypto.Hash
+import           Data.Bool
+import           Data.Byteable
+import qualified Data.ByteString                  as BS
+import           Data.Either
+import           Data.Either.Validation
+import           Data.Foldable
+import           Data.Maybe
+
+import           Crypto.Macaroon.Internal
+
+data Win = Win
+
+data ValidationError = SigMismatch
+                     | NoVerifier
+                     | ParseError String
+                     | ValidatorError String
+                     deriving Show
+
+instance Monoid ValidationError where
+    mempty = NoVerifier
+    NoVerifier `mappend` e = e
+    e `mappend` NoVerifier = e
+    SigMismatch `mappend` _ = SigMismatch
+    _ `mappend` SigMismatch = SigMismatch
+    (ValidatorError e) `mappend` (ParseError _) = ValidatorError e
+    (ParseError _) `mappend` (ValidatorError e) = ValidatorError e
+
+
+verifySig :: Key -> Macaroon -> Either ValidationError Macaroon
+verifySig k m = bool (Left SigMismatch) (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)
+
+
+verifyCavs :: MonadIO m
+           => [Caveat -> m (Maybe (Either ValidationError Caveat))]
+           -> Macaroon
+           -> m (Either ValidationError Macaroon)
+verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m)
+  where
+    {-
+     - validateCaveat :: Caveat -> m (Validation String Caveat)
+     - We can use fromJust here safely since we use a `Just Failure` as a
+     - starting value for the foldM. We are guaranteed to have a `Just something`
+     - from it.
+     -}
+    validateCaveat c = fromJust <$> foldM (\res v -> mappend res . fmap eitherToValidation <$> v c) (defErr c) verifiers
+    -- defErr :: Caveat -> Maybe (Validation String Caveat)
+    defErr c = Just $ Failure NoVerifier
+    -- gatherEithers :: [Validation String Caveat] -> Either String Caveat
+    gatherEithers vs = case partitionEithers . map validationToEither $ vs of
+        ([],_) ->  Right m
+        (errs,_) -> Left (mconcat errs)
diff --git a/test/Crypto/Macaroon/Verifier/Tests.hs b/test/Crypto/Macaroon/Verifier/Tests.hs
index 4a9295f..670c991 100644
--- a/test/Crypto/Macaroon/Verifier/Tests.hs
+++ b/test/Crypto/Macaroon/Verifier/Tests.hs
@@ -63,3 +63,39 @@ m3 = addFirstPartyCaveat "value = 42" m2
 sigs = testProperty "Signatures" $ \sm -> verifySig (secret sm) (macaroon sm) == Right (macaroon sm)
 
 -- TODO: Re-do tests
+{-
+firstParty = testGroup "First party caveats" [
+    testGroup "Pure verifiers" [
+        testProperty "Zero caveat" $
+                forAll (sublistOf allvs) (\vs -> Right m == verifyCavs vs m)
+      , testProperty "One caveat" $
+          forAll (sublistOf allvs) (\vs -> disjoin [
+              Right m2 == verifyCavs vs m2 .&&. any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs)
+            , True === isLeft( verifyCavs vs m2)
+            ])
+      , testProperty "Two Exact" $
+          forAll (sublistOf allvs) (\vs -> disjoin [
+              Right m3 == verifyCavs vs m3 .&&.
+                any (`elem` vs) [exTC,funTCPre] .&&.  (exTZ `notElem` vs) .&&.
+                any (`elem` vs) [exV42,funTV43lte] .&&.  (exV43 `notElem` vs)
+            , True === isLeft (verifyCavs vs m3)
+            ])
+      ]
+    , testGroup "Pure verifiers with sig" [
+        testProperty "Zero caveat" $
+                forAll (sublistOf allvs) (\vs -> Right m == verifyMacaroon sec vs m)
+      , testProperty "One caveat" $
+          forAll (sublistOf allvs) (\vs -> disjoin [
+              Right m2 == verifyMacaroon sec vs m2 .&&. any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs)
+            , True === isLeft (verifyMacaroon sec vs m2)
+            ])
+      , testProperty "Two Exact" $
+          forAll (sublistOf allvs) (\vs -> disjoin [
+              Right m3 == verifyMacaroon sec vs m3 .&&.
+                any (`elem` vs) [exTC,funTCPre] .&&.  (exTZ `notElem` vs) .&&.
+                any (`elem` vs) [exV42,funTV43lte] .&&.  (exV43 `notElem` vs)
+            , True === isLeft (verifyMacaroon sec vs m3)
+            ])
+      ]
+    ]
+    -}