aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--default.nix6
-rw-r--r--hmacaroons.cabal2
-rw-r--r--src/Crypto/Macaroon/Verifier.hs48
-rw-r--r--src/Crypto/Macaroon/Verifier/Internal.hs15
-rw-r--r--test/Crypto/Macaroon/Verifier/Internal/Tests.hs12
5 files changed, 30 insertions, 53 deletions
diff --git a/default.nix b/default.nix
index a392583..bcaf974 100644
--- a/default.nix
+++ b/default.nix
@@ -4,13 +4,13 @@
4}: 4}:
5mkDerivation { 5mkDerivation {
6 pname = "hmacaroons"; 6 pname = "hmacaroons";
7 version = "0.4.0.0"; 7 version = "0.5.0.0";
8 src = ./.; 8 src = ./.;
9 buildDepends = [ 9 libraryHaskellDepends = [
10 attoparsec base base64-bytestring byteable bytestring cereal 10 attoparsec base base64-bytestring byteable bytestring cereal
11 cryptohash deepseq either hex transformers 11 cryptohash deepseq either hex transformers
12 ]; 12 ];
13 testDepends = [ 13 testHaskellDepends = [
14 attoparsec base base64-bytestring byteable bytestring cereal 14 attoparsec base base64-bytestring byteable bytestring cereal
15 cryptohash deepseq either hex QuickCheck tasty tasty-hunit 15 cryptohash deepseq either hex QuickCheck tasty tasty-hunit
16 tasty-quickcheck transformers 16 tasty-quickcheck transformers
diff --git a/hmacaroons.cabal b/hmacaroons.cabal
index 3f0bd89..81a9c33 100644
--- a/hmacaroons.cabal
+++ b/hmacaroons.cabal
@@ -1,5 +1,5 @@
1name: hmacaroons 1name: hmacaroons
2version: 0.4.0.0 2version: 0.5.0.0
3synopsis: Haskell implementation of macaroons 3synopsis: Haskell implementation of macaroons
4description: 4description:
5 Hmacaroons is a pure haskell implementation of macaroons. It aims to 5 Hmacaroons is a pure haskell implementation of macaroons. It aims to
diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs
index 4fc6aff..a3bf5d4 100644
--- a/src/Crypto/Macaroon/Verifier.hs
+++ b/src/Crypto/Macaroon/Verifier.hs
@@ -17,9 +17,8 @@ Portability : portable
17-} 17-}
18module Crypto.Macaroon.Verifier ( 18module Crypto.Macaroon.Verifier (
19 verify 19 verify
20 , VerifierResult(..)
20 , ValidationError(ValidatorError, ParseError) 21 , ValidationError(ValidatorError, ParseError)
21 -- , (.<), (.<=), (.==), (.>), (.>=)
22 -- , module Data.Attoparsec.ByteString.Char8
23) where 22) where
24 23
25 24
@@ -38,55 +37,22 @@ import Crypto.Macaroon.Verifier.Internal
38 37
39 38
40 39
41
42-- (.<) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
43-- (.<) = verifyOpBool "Greater or equal" (<) "<"
44
45-- (.<=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
46-- (.<=) = verifyOpBool "Strictly greater" (<=) "<="
47
48-- (.==) :: (MonadIO m, Eq a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
49-- (.==) = verifyOpBool "Not equal" (==) "="
50
51-- (.>) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
52-- (.>) = verifyOpBool "Less or equal" (>) ">"
53
54-- (.>=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
55-- (.>=) = verifyOpBool "Strictly less" (>=) ">="
56
57-- | Verify a Macaroon's signature and caveats, given the corresponding Secret 40-- | Verify a Macaroon's signature and caveats, given the corresponding Secret
58-- and verifiers. 41-- and verifiers.
59-- 42--
60-- A verifier is a function of type 43-- A verifier is a function of type
61-- @'MonadIO' m => 'Caveat' -> m ('Maybe' ('Either' 'ValidatorError' 'Caveat'))@. 44-- @'MonadIO' m => 'Caveat' -> m VerifierResult@.
62-- 45--
63-- It should return: 46-- It should return:
64-- 47--
65-- * 'Nothing' if the caveat is not related to the verifier 48-- * 'Unrelated' if the caveat is not related to the verifier
66-- (for instance a time verifier is given an action caveat); 49-- (for instance a time verifier is given an action caveat);
67-- * 'Just' ('Left' ('ParseError' reason)) if the verifier is related to the 50-- * 'Refused' ('ParseError' reason) if the verifier is related to the
68-- caveat, but failed to parse it completely; 51-- caveat, but failed to parse it completely;
69-- * 'Just' ('Left' ('ValidatorError' reason)) if the verifier is related to the 52-- * 'Refused' ('ValidatorError' reason) if the verifier is related to the
70-- caveat, parsed it and invalidated it; 53-- caveat, parsed it and invalidated it;
71-- * 'Just' ('Right' '()') if the verifier has successfully verified the 54-- * 'Verified' if the verifier has successfully verified the
72-- given caveat 55-- given caveat
73verify :: (Functor m, MonadIO m) => Secret -> [Caveat -> m (Maybe (Either ValidationError ()))] -> Macaroon -> m (Either ValidationError Macaroon) 56verify :: (Functor m, MonadIO m) => Secret -> [Caveat -> m VerifierResult] -> Macaroon -> m (Either ValidationError Macaroon)
74verify secret verifiers m = join <$> forM (verifySig secret m) (verifyCavs verifiers) 57verify secret verifiers m = join <$> forM (verifySig secret m) (verifyCavs verifiers)
75 58
76
77-- verifyOpBool :: MonadIO m => String -> Parser a -> (a -> a -> Bool) -> BS.ByteString -> Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
78-- verifyOpBool err p f op k val = verifyParser k valueParser $ \s -> do
79-- expected <- val
80-- return $ bool (Left $ ValidatorError err) (Right Win) =<< f expected <$> mapLeft ParseError (parseOnly p s)
81-- where
82-- valueParser = string op *> skipSpace *> takeByteString
83
84-- verifyParser :: (MonadIO m) => Key -> Parser a -> (a -> m (Either ValidationError Win)) -> Caveat -> m (Maybe (Either ValidationError Caveat))
85-- verifyParser k p f c = case parseOnly keyParser . cid $ c of
86-- Left _ -> return Nothing
87-- Right bs -> Just <$> case parseOnly p bs of
88-- Left err -> return $ Left $ ParseError err
89-- Right a -> fmap (const c) <$> f a
90-- where
91-- keyParser = string k *> skipSpace *> takeByteString
92
diff --git a/src/Crypto/Macaroon/Verifier/Internal.hs b/src/Crypto/Macaroon/Verifier/Internal.hs
index b3ad7f2..6228608 100644
--- a/src/Crypto/Macaroon/Verifier/Internal.hs
+++ b/src/Crypto/Macaroon/Verifier/Internal.hs
@@ -29,6 +29,13 @@ import Data.Monoid
29 29
30import Crypto.Macaroon.Internal 30import Crypto.Macaroon.Internal
31 31
32
33-- | Type representing the result of a validator
34data VerifierResult = Verified -- ^ The caveat is correctly parsed and verified
35 | Refused ValidationError -- ^ The caveat is refused (Either a parse error or a validation error
36 | Unrelated -- ^ The given verifier does not verify the caveat
37 deriving (Show, Eq)
38
32-- | Type representing different validation errors. 39-- | Type representing different validation errors.
33-- Only 'ParseError' and 'ValidatorError' are exported, @SigMismatch@ and 40-- Only 'ParseError' and 'ValidatorError' are exported, @SigMismatch@ and
34-- @NoVerifier@ are used internally and should not be used by the user 41-- @NoVerifier@ are used internally and should not be used by the user
@@ -59,7 +66,7 @@ verifySig k m = bool (Left SigMismatch) (Right m) $
59 66
60-- | Given a list of verifiers, verify each caveat of the given macaroon 67-- | Given a list of verifiers, verify each caveat of the given macaroon
61verifyCavs :: (Functor m, MonadIO m) 68verifyCavs :: (Functor m, MonadIO m)
62 => [Caveat -> m (Maybe (Either ValidationError ()))] 69 => [Caveat -> m VerifierResult]
63 -> Macaroon 70 -> Macaroon
64 -> m (Either ValidationError Macaroon) 71 -> m (Either ValidationError Macaroon)
65verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m) 72verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m)
@@ -70,7 +77,11 @@ verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m)
70 - starting value for the foldM. We are guaranteed to have a `Just something` 77 - starting value for the foldM. We are guaranteed to have a `Just something`
71 - from it. 78 - from it.
72 -} 79 -}
73 validateCaveat c = fmap (const c) . fromJust <$> foldM (\res v -> mappend res . fmap eitherToValidation <$> v c) (defErr c) verifiers 80 validateCaveat c = fmap (const c) . fromJust <$> foldM (\res v -> mappend res . fmap eitherToValidation . vResult2MaybeEither <$> v c) (defErr c) verifiers
81 -- vResult2MaybeEither :: VerifierResult -> Maybe (Either ValidationError ())
82 vResult2MaybeEither Unrelated = Nothing
83 vResult2MaybeEither Verified = Just (Right ())
84 vResult2MaybeEither (Refused e)= Just (Left e)
74 -- defErr :: Caveat -> Maybe (Validation String Caveat) 85 -- defErr :: Caveat -> Maybe (Validation String Caveat)
75 defErr c = Just $ Failure NoVerifier 86 defErr c = Just $ Failure NoVerifier
76 -- gatherEithers :: [Validation String Caveat] -> Either String Caveat 87 -- gatherEithers :: [Validation String Caveat] -> Either String Caveat
diff --git a/test/Crypto/Macaroon/Verifier/Internal/Tests.hs b/test/Crypto/Macaroon/Verifier/Internal/Tests.hs
index 826b631..59980de 100644
--- a/test/Crypto/Macaroon/Verifier/Internal/Tests.hs
+++ b/test/Crypto/Macaroon/Verifier/Internal/Tests.hs
@@ -45,19 +45,19 @@ m = create sec key loc
45m2 :: Macaroon 45m2 :: Macaroon
46m2 = addFirstPartyCaveat "test = caveat" m 46m2 = addFirstPartyCaveat "test = caveat" m
47 47
48vtest :: Caveat -> IO (Maybe (Either ValidationError ())) 48vtest :: Caveat -> IO VerifierResult
49vtest c = return $ if "test" `BS.isPrefixOf` cid c then 49vtest c = return $ if "test" `BS.isPrefixOf` cid c then
50 Just $ bool (Left (ValidatorError "Failed")) (Right ()) $ "test = caveat" == cid c 50 bool (Refused (ValidatorError "Failed")) Verified $ "test = caveat" == cid c
51 else Nothing 51 else Unrelated
52 52
53 53
54m3 :: Macaroon 54m3 :: Macaroon
55m3 = addFirstPartyCaveat "value = 42" m2 55m3 = addFirstPartyCaveat "value = 42" m2
56 56
57vval :: Caveat -> IO (Maybe (Either ValidationError ())) 57vval :: Caveat -> IO VerifierResult
58vval c = return $ if "value" `BS.isPrefixOf` cid c then 58vval c = return $ if "value" `BS.isPrefixOf` cid c then
59 Just $ bool (Left (ValidatorError "Failed")) (Right ()) $ "value = 42" == cid c 59 bool (Refused (ValidatorError "Failed")) Verified $ "value = 42" == cid c
60 else Nothing 60 else Unrelated
61 61
62 62
63{- 63{-