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     Verified(..)
  17   , verifySig
  18   , verifyExact
  19   , verifyFun
  20   , verifyCavs
  21   -- , module Data.Attoparsec.ByteString
  22   , module Data.Attoparsec.ByteString.Char8
  23 ) where
  24
  25
  26 import           Crypto.Hash
  27 import           Data.Bool
  28 import qualified Data.ByteString            as BS
  29 import           Data.Byteable
  30 import           Data.Foldable
  31 import           Data.Maybe
  32 import Data.Attoparsec.ByteString
  33 import Data.Attoparsec.ByteString.Char8
  34
  35 import           Crypto.Macaroon.Internal
  36
  37
  38 -- | Opaque datatype for now. Might need more explicit errors
  39 data Verified = Ok | Failed deriving (Show,Eq)
  40
  41 instance Monoid Verified where
  42   mempty = Ok
  43   mappend Ok Ok = Ok
  44   mappend _ _ = Failed
  45
  46
  47 type CaveatVerifier = Caveat -> Maybe Verified
  48
  49 verifySig :: Key -> Macaroon -> Verified
  50 verifySig k m = bool Failed Ok $
  51       signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m)
  52   where
  53     hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256)
  54     derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256)
  55
  56 verifyCavs :: [Caveat -> Maybe Verified] -> Macaroon -> Verified
  57 verifyCavs verifiers m = mconcat $ map (\c -> mconcat . catMaybes $ map ($ c) verifiers) (caveats m)
  58
  59 verifyExact :: (Eq a) => Key -> a -> Parser a -> Caveat -> Maybe Verified
  60 verifyExact k expected = verifyFun k (expected ==)
  61
  62 verifyFun :: Key -> (a -> Bool) -> Parser a -> Caveat -> Maybe Verified
  63 verifyFun key f parser cav = if key `BS.isPrefixOf` cid cav then
  64         case parseOnly kvparser (cid cav) of
  65           Right v -> (bool Failed Ok . f) <$> Just v
  66           Left _ -> Just Failed
  67         else Nothing
  68   where
  69     kvparser = do
  70       key <- string key
  71       skipSpace
  72       string "="
  73       skipSpace
  74       parser <* endOfInput