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