1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RankNTypes #-}
4 Module : Crypto.Macaroon.Verifier.Internal
5 Copyright : (c) 2015 Julien Tanguy
8 Maintainer : julien.tanguy@jhome.fr
9 Stability : experimental
10 Portability : portable
15 module Crypto.Macaroon.Verifier.Internal where
17 import Control.Applicative
19 import Control.Monad.IO.Class
23 import qualified Data.ByteString as BS
25 import Data.Either.Validation
30 import Crypto.Macaroon.Internal
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
41 -- | The 'Monoid' instance is written so @SigMismatch@ is an annihilator,
42 -- and @NoVerifier@ is the identity element
43 instance Monoid ValidationError where
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
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)
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)
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 ()))]
64 -> m (Either ValidationError Macaroon)
65 verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m)
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`
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
79 (errs,_) -> Left (mconcat errs)