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   , verifyMacaroon
  20   , verifySig
  21   , verifyExact
  22   , verifyFun
  23   , module Data.Attoparsec.ByteString.Char8
  24   , verifyCavs
  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 verifyMacaroon :: Key -> [CaveatVerifier] -> Macaroon -> Verified
  70 verifyMacaroon secret verifiers m = verifySig secret m `mappend` verifyCavs verifiers m
  71
  72
  73 verifyCavs :: [CaveatVerifier] -> Macaroon -> Verified
  74 verifyCavs verifiers m = foldMap (\c -> fromMaybe Failed $ foldMap (($ c) . vFun) verifiers) (caveats m)
  75
  76 verifyExact :: (Eq a) => Key -> a -> Parser a -> Caveat -> Maybe Verified
  77 verifyExact k expected = verifyFun k (expected ==)
  78
  79 verifyFun :: Key -> (a -> Bool) -> Parser a -> Caveat -> Maybe Verified
  80 verifyFun key f parser cav = if key `BS.isPrefixOf` cid cav then
  81         case parseOnly kvparser (cid cav) of
  82           Right v -> (bool Failed Ok . f) <$> Just v
  83           Left _ -> Just Failed
  84         else Nothing
  85   where
  86     kvparser = do
  87       key <- string key
  88       skipSpace
  89       string "="
  90       skipSpace
  91       parser <* endOfInput