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.Monad
  18 import           Control.Monad.IO.Class
  19 import           Crypto.Hash
  20 import           Data.Bool
  21 import           Data.Byteable
  22 import qualified Data.ByteString                  as BS
  23 import           Data.Either
  24 import           Data.Either.Validation
  25 import           Data.Foldable
  26 import           Data.Maybe
  27
  28 import           Crypto.Macaroon.Internal
  29
  30 data Win = Win
  31
  32 data ValidationError = SigMismatch
  33                      | NoVerifier
  34                      | ParseError String
  35                      | ValidatorError String
  36                      deriving Show
  37
  38 instance Monoid ValidationError where
  39     mempty = NoVerifier
  40     NoVerifier `mappend` e = e
  41     e `mappend` NoVerifier = e
  42     SigMismatch `mappend` _ = SigMismatch
  43     _ `mappend` SigMismatch = SigMismatch
  44     (ValidatorError e) `mappend` (ParseError _) = ValidatorError e
  45     (ParseError _) `mappend` (ValidatorError e) = ValidatorError e
  46
  47
  48 verifySig :: Key -> Macaroon -> Either ValidationError Macaroon
  49 verifySig k m = bool (Left SigMismatch) (Right m) $
  50     signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m)
  51   where
  52     hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256)
  53     derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256)
  54
  55
  56 verifyCavs :: MonadIO m
  57            => [Caveat -> m (Maybe (Either ValidationError Caveat))]
  58            -> Macaroon
  59            -> m (Either ValidationError Macaroon)
  60 verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m)
  61   where
  62     {-
  63      - validateCaveat :: Caveat -> m (Validation String Caveat)
  64      - We can use fromJust here safely since we use a `Just Failure` as a
  65      - starting value for the foldM. We are guaranteed to have a `Just something`
  66      - from it.
  67      -}
  68     validateCaveat c = fromJust <$> foldM (\res v -> mappend res . fmap eitherToValidation <$> v c) (defErr c) verifiers
  69     -- defErr :: Caveat -> Maybe (Validation String Caveat)
  70     defErr c = Just $ Failure NoVerifier
  71     -- gatherEithers :: [Validation String Caveat] -> Either String Caveat
  72     gatherEithers vs = case partitionEithers . map validationToEither $ vs of
  73         ([],_) ->  Right m
  74         (errs,_) -> Left (mconcat errs)