diff options
Diffstat (limited to 'src/Crypto/Macaroon')
-rw-r--r-- | src/Crypto/Macaroon/Internal.hs | 6 | ||||
-rw-r--r-- | src/Crypto/Macaroon/Verifier.hs | 142 | ||||
-rw-r--r-- | src/Crypto/Macaroon/Verifier/Internal.hs | 79 |
3 files changed, 155 insertions, 72 deletions
diff --git a/src/Crypto/Macaroon/Internal.hs b/src/Crypto/Macaroon/Internal.hs index 2f56512..d6e80d3 100644 --- a/src/Crypto/Macaroon/Internal.hs +++ b/src/Crypto/Macaroon/Internal.hs | |||
@@ -23,7 +23,11 @@ import qualified Data.ByteString.Char8 as B8 | |||
23 | import Data.Hex | 23 | import Data.Hex |
24 | import Data.List | 24 | import Data.List |
25 | 25 | ||
26 | -- |Type alias for Macaroons and Caveat keys and identifiers | 26 | |
27 | -- |Type alias for Macaroons secret keys | ||
28 | type Secret = BS.ByteString | ||
29 | |||
30 | -- |Type alias for Macaroons and Caveat and identifiers | ||
27 | type Key = BS.ByteString | 31 | type Key = BS.ByteString |
28 | 32 | ||
29 | -- |Type alias for Macaroons and Caveat locations | 33 | -- |Type alias for Macaroons and Caveat locations |
diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs index ed24ea4..4fc6aff 100644 --- a/src/Crypto/Macaroon/Verifier.hs +++ b/src/Crypto/Macaroon/Verifier.hs | |||
@@ -1,5 +1,8 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | 1 | {-# LANGUAGE FlexibleInstances #-} |
2 | {-# LANGUAGE RankNTypes #-} | 2 | {-# LANGUAGE OverloadedStrings #-} |
3 | {-# LANGUAGE RankNTypes #-} | ||
4 | {-# LANGUAGE TypeSynonymInstances #-} | ||
5 | {-# LANGUAGE UndecidableInstances #-} | ||
3 | {-| | 6 | {-| |
4 | Module : Crypto.Macaroon.Verifier | 7 | Module : Crypto.Macaroon.Verifier |
5 | Copyright : (c) 2015 Julien Tanguy | 8 | Copyright : (c) 2015 Julien Tanguy |
@@ -13,80 +16,77 @@ Portability : portable | |||
13 | 16 | ||
14 | -} | 17 | -} |
15 | module Crypto.Macaroon.Verifier ( | 18 | module Crypto.Macaroon.Verifier ( |
16 | Verified(..) | 19 | verify |
17 | , CaveatVerifier | 20 | , ValidationError(ValidatorError, ParseError) |
18 | , (<???>) | 21 | -- , (.<), (.<=), (.==), (.>), (.>=) |
19 | , verifyMacaroon | 22 | -- , module Data.Attoparsec.ByteString.Char8 |
20 | , verifySig | ||
21 | , verifyExact | ||
22 | , verifyFun | ||
23 | , module Data.Attoparsec.ByteString.Char8 | ||
24 | , verifyCavs | ||
25 | ) where | 23 | ) where |
26 | 24 | ||
27 | 25 | ||
28 | import Crypto.Hash | 26 | import Control.Applicative |
27 | import Control.Monad hiding (forM) | ||
28 | import Control.Monad.IO.Class | ||
29 | import Data.Attoparsec.ByteString | ||
30 | import Data.Attoparsec.ByteString.Char8 | ||
29 | import Data.Bool | 31 | import Data.Bool |
30 | import qualified Data.ByteString as BS | ||
31 | import Data.Byteable | ||
32 | import Data.Foldable | ||
33 | import Data.Function | ||
34 | import Data.Maybe | ||
35 | import Data.Monoid | ||
36 | import Data.Traversable | 32 | import Data.Traversable |
37 | import Data.Attoparsec.ByteString | 33 | import qualified Data.ByteString as BS |
38 | import Data.Attoparsec.ByteString.Char8 | 34 | import Data.Either.Combinators |
39 | 35 | ||
40 | import Crypto.Macaroon.Internal | 36 | import Crypto.Macaroon.Internal |
37 | import Crypto.Macaroon.Verifier.Internal | ||
38 | |||
39 | |||
40 | |||
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 | ||
58 | -- and verifiers. | ||
59 | -- | ||
60 | -- A verifier is a function of type | ||
61 | -- @'MonadIO' m => 'Caveat' -> m ('Maybe' ('Either' 'ValidatorError' 'Caveat'))@. | ||
62 | -- | ||
63 | -- It should return: | ||
64 | -- | ||
65 | -- * 'Nothing' if the caveat is not related to the verifier | ||
66 | -- (for instance a time verifier is given an action caveat); | ||
67 | -- * 'Just' ('Left' ('ParseError' reason)) if the verifier is related to the | ||
68 | -- caveat, but failed to parse it completely; | ||
69 | -- * 'Just' ('Left' ('ValidatorError' reason)) if the verifier is related to the | ||
70 | -- caveat, parsed it and invalidated it; | ||
71 | -- * 'Just' ('Right' '()') if the verifier has successfully verified the | ||
72 | -- given caveat | ||
73 | verify :: (Functor m, MonadIO m) => Secret -> [Caveat -> m (Maybe (Either ValidationError ()))] -> Macaroon -> m (Either ValidationError Macaroon) | ||
74 | verify secret verifiers m = join <$> forM (verifySig secret m) (verifyCavs verifiers) | ||
75 | |||
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 | ||
41 | 92 | ||
42 | |||
43 | -- | Opaque datatype for now. Might need more explicit errors | ||
44 | data Verified = Ok | Failed deriving (Show,Eq) | ||
45 | |||
46 | instance Monoid Verified where | ||
47 | mempty = Ok | ||
48 | mappend Ok Ok = Ok | ||
49 | mappend _ _ = Failed | ||
50 | |||
51 | |||
52 | data CaveatVerifier = CV { vFun :: Caveat -> Maybe Verified , helpText :: String} | ||
53 | |||
54 | instance Eq CaveatVerifier where | ||
55 | (==) = (==) `on` helpText | ||
56 | |||
57 | instance Show CaveatVerifier where | ||
58 | show = helpText | ||
59 | |||
60 | (<???>) :: (Caveat -> Maybe Verified) -> String -> CaveatVerifier | ||
61 | f <???> t = CV f t | ||
62 | |||
63 | verifySig :: Key -> Macaroon -> Verified | ||
64 | verifySig k m = bool Failed Ok $ | ||
65 | signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m) | ||
66 | where | ||
67 | hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256) | ||
68 | derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256) | ||
69 | |||
70 | verifyMacaroon :: Key -> [CaveatVerifier] -> Macaroon -> Verified | ||
71 | verifyMacaroon secret verifiers m = verifySig secret m `mappend` verifyCavs verifiers m | ||
72 | |||
73 | |||
74 | verifyCavs :: [CaveatVerifier] -> Macaroon -> Verified | ||
75 | verifyCavs verifiers m = foldMap (\c -> fromMaybe Failed $ foldMap (($ c) . vFun) verifiers) (caveats m) | ||
76 | |||
77 | verifyExact :: (Eq a) => Key -> a -> Parser a -> Caveat -> Maybe Verified | ||
78 | verifyExact k expected = verifyFun k (expected ==) | ||
79 | |||
80 | verifyFun :: Key -> (a -> Bool) -> Parser a -> Caveat -> Maybe Verified | ||
81 | verifyFun key f parser cav = if key `BS.isPrefixOf` cid cav then | ||
82 | case parseOnly kvparser (cid cav) of | ||
83 | Right v -> (bool Failed Ok . f) <$> Just v | ||
84 | Left _ -> Just Failed | ||
85 | else Nothing | ||
86 | where | ||
87 | kvparser = do | ||
88 | key <- string key | ||
89 | skipSpace | ||
90 | string "=" | ||
91 | skipSpace | ||
92 | parser <* endOfInput | ||
diff --git a/src/Crypto/Macaroon/Verifier/Internal.hs b/src/Crypto/Macaroon/Verifier/Internal.hs new file mode 100644 index 0000000..b3ad7f2 --- /dev/null +++ b/src/Crypto/Macaroon/Verifier/Internal.hs | |||
@@ -0,0 +1,79 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | {-# LANGUAGE RankNTypes #-} | ||
3 | {-| | ||
4 | Module : Crypto.Macaroon.Verifier.Internal | ||
5 | Copyright : (c) 2015 Julien Tanguy | ||
6 | License : BSD3 | ||
7 | |||
8 | Maintainer : julien.tanguy@jhome.fr | ||
9 | Stability : experimental | ||
10 | Portability : portable | ||
11 | |||
12 | |||
13 | |||
14 | -} | ||
15 | module Crypto.Macaroon.Verifier.Internal where | ||
16 | |||
17 | import Control.Applicative | ||
18 | import Control.Monad | ||
19 | import Control.Monad.IO.Class | ||
20 | import Crypto.Hash | ||
21 | import Data.Bool | ||
22 | import Data.Byteable | ||
23 | import qualified Data.ByteString as BS | ||
24 | import Data.Either | ||
25 | import Data.Either.Validation | ||
26 | import Data.Foldable | ||
27 | import Data.Maybe | ||
28 | import Data.Monoid | ||
29 | |||
30 | import Crypto.Macaroon.Internal | ||
31 | |||
32 | -- | Type representing different validation errors. | ||
33 | -- Only 'ParseError' and 'ValidatorError' are exported, @SigMismatch@ and | ||
34 | -- @NoVerifier@ are used internally and should not be used by the user | ||
35 | data ValidationError = SigMismatch -- ^ Signatures do not match | ||
36 | | NoVerifier -- ^ No verifier can handle a given caveat | ||
37 | | ParseError String -- ^ A verifier had a parse error | ||
38 | | ValidatorError String -- ^ A verifier failed | ||
39 | deriving (Show,Eq) | ||
40 | |||
41 | -- | The 'Monoid' instance is written so @SigMismatch@ is an annihilator, | ||
42 | -- and @NoVerifier@ is the identity element | ||
43 | instance Monoid ValidationError where | ||
44 | mempty = NoVerifier | ||
45 | NoVerifier `mappend` e = e | ||
46 | e `mappend` NoVerifier = e | ||
47 | SigMismatch `mappend` _ = SigMismatch | ||
48 | _ `mappend` SigMismatch = SigMismatch | ||
49 | (ValidatorError e) `mappend` (ParseError _) = ValidatorError e | ||
50 | (ParseError _) `mappend` (ValidatorError e) = ValidatorError e | ||
51 | |||
52 | -- | Check that the given macaroon has a correct signature | ||
53 | verifySig :: Key -> Macaroon -> Either ValidationError Macaroon | ||
54 | verifySig k m = bool (Left SigMismatch) (Right m) $ | ||
55 | signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m) | ||
56 | where | ||
57 | hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256) | ||
58 | derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256) | ||
59 | |||
60 | -- | Given a list of verifiers, verify each caveat of the given macaroon | ||
61 | verifyCavs :: (Functor m, MonadIO m) | ||
62 | => [Caveat -> m (Maybe (Either ValidationError ()))] | ||
63 | -> Macaroon | ||
64 | -> m (Either ValidationError Macaroon) | ||
65 | verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m) | ||
66 | where | ||
67 | {- | ||
68 | - validateCaveat :: Caveat -> m (Validation String Caveat) | ||
69 | - We can use fromJust here safely since we use a `Just Failure` as a | ||
70 | - starting value for the foldM. We are guaranteed to have a `Just something` | ||
71 | - from it. | ||
72 | -} | ||
73 | validateCaveat c = fmap (const c) . fromJust <$> foldM (\res v -> mappend res . fmap eitherToValidation <$> v c) (defErr c) verifiers | ||
74 | -- defErr :: Caveat -> Maybe (Validation String Caveat) | ||
75 | defErr c = Just $ Failure NoVerifier | ||
76 | -- gatherEithers :: [Validation String Caveat] -> Either String Caveat | ||
77 | gatherEithers vs = case partitionEithers . map validationToEither $ vs of | ||
78 | ([],_) -> Right m | ||
79 | (errs,_) -> Left (mconcat errs) | ||