src/Crypto/Macaroon/Verifier/Internal.hs

   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)