src/Crypto/Macaroon/Verifier.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RankNTypes        #-}
   3 {-|
   4 Module      : Crypto.Macaroon.Verifier
   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 (
  16     Verifier
  17   , verifyMacaroon
  18   , verifySig
  19   -- , verifyExact
  20   -- , verifyFun
  21   , module Data.Attoparsec.ByteString.Char8
  22   , verifyCavs
  23 ) where
  24
  25
  26 import           Crypto.Hash
  27 import           Data.Attoparsec.ByteString
  28 import           Data.Attoparsec.ByteString.Char8
  29 import           Data.Bool
  30 import           Data.Byteable
  31 import qualified Data.ByteString                  as BS
  32 import           Data.Either
  33 import           Data.Either.Validation
  34 import           Data.Foldable
  35 import           Data.Function
  36 import           Data.Maybe
  37 import           Data.Traversable
  38
  39 import           Crypto.Macaroon.Internal
  40
  41 type Verifier = Caveat -> Maybe (Either String Caveat)
  42
  43 verifySig :: Key -> Macaroon -> Either String Macaroon
  44 verifySig k m = bool (Left "Signatures do not match") (Right m) $
  45       signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m)
  46   where
  47     hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256)
  48     derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256)
  49
  50 verifyMacaroon :: Key -> [Verifier] -> Macaroon -> Either String Macaroon
  51 verifyMacaroon secret verifiers m = verifySig secret m >>= verifyCavs verifiers
  52
  53 verifyCavs :: [Verifier] -> Macaroon -> Either String Macaroon
  54 verifyCavs verifiers m = case partitionEithers verifiedCaveats of
  55     ([],_) -> Right m
  56     (errs,_) -> Left (mconcat errs)
  57   where
  58     verifiedCaveats = map (\c -> defaultFail c $ foldMap (fmap eitherToValidation . ($c)) verifiers) $ caveats m
  59     defaultFail c = maybe (Left ("No validation for this caveat: " ++ show c)) validationToEither
  60
  61
  62 -- TODO: define API