+{-# 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)