src/Crypto/Macaroon/Verifier.hs

   1 {-# LANGUAGE FlexibleInstances    #-}
   2 {-# LANGUAGE OverloadedStrings    #-}
   3 {-# LANGUAGE RankNTypes           #-}
   4 {-# LANGUAGE TypeSynonymInstances #-}
   5 {-# LANGUAGE UndecidableInstances #-}
   6 {-|
   7 Module      : Crypto.Macaroon.Verifier
   8 Copyright   : (c) 2015 Julien Tanguy
   9 License     : BSD3
  10
  11 Maintainer  : julien.tanguy@jhome.fr
  12 Stability   : experimental
  13 Portability : portable
  14
  15
  16
  17 -}
  18 module Crypto.Macaroon.Verifier (
  19     verify
  20   , ValidationError(ValidatorError, ParseError)
  21   -- , (.<), (.<=), (.==), (.>), (.>=)
  22   -- , module Data.Attoparsec.ByteString.Char8
  23 ) where
  24
  25
  26 import           Control.Applicative
  27 import           Control.Monad hiding (forM)
  28 import           Control.Monad.IO.Class
  29 import           Data.Attoparsec.ByteString
  30 import           Data.Attoparsec.ByteString.Char8
  31 import           Data.Bool
  32 import           Data.Traversable
  33 import qualified Data.ByteString                  as BS
  34 import           Data.Either.Combinators
  35
  36 import           Crypto.Macaroon.Internal
  37 import           Crypto.Macaroon.Verifier.Internal
  38
  39
  40
  41
  42 -- (.<) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
  43 -- (.<) = verifyOpBool "Greater or equal" (<) "<"
  44
  45 -- (.<=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
  46 -- (.<=) = verifyOpBool "Strictly greater" (<=) "<="
  47
  48 -- (.==) :: (MonadIO m, Eq a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
  49 -- (.==) = verifyOpBool "Not equal" (==) "="
  50
  51 -- (.>) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
  52 -- (.>) = verifyOpBool "Less or equal" (>) ">"
  53
  54 -- (.>=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
  55 -- (.>=) = verifyOpBool "Strictly less" (>=) ">="
  56
  57 -- | Verify a Macaroon's signature and caveats, given the corresponding Secret
  58 -- and verifiers.
  59 --
  60 -- A verifier is a function of type
  61 -- @'MonadIO' m => 'Caveat' -> m ('Maybe' ('Either' 'ValidatorError' 'Caveat'))@.
  62 --
  63 -- It should return:
  64 --
  65 -- * 'Nothing' if the caveat is not related to the verifier
  66 -- (for instance a time verifier is given an action caveat);
  67 -- * 'Just' ('Left' ('ParseError' reason)) if the verifier  is related to the
  68 -- caveat, but failed to parse it completely;
  69 -- * 'Just' ('Left' ('ValidatorError' reason)) if the verifier is related to the
  70 -- caveat, parsed it and invalidated it;
  71 -- * 'Just' ('Right' '()') if the verifier has successfully verified the
  72 -- given caveat
  73 verify :: (Functor m, MonadIO m) => Secret -> [Caveat -> m (Maybe (Either ValidationError ()))] -> Macaroon -> m (Either ValidationError Macaroon)
  74 verify secret verifiers m = join <$> forM (verifySig secret m) (verifyCavs verifiers)
  75
  76
  77 -- verifyOpBool :: MonadIO m => String -> Parser a -> (a -> a -> Bool) -> BS.ByteString -> Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
  78 -- verifyOpBool err p f op k val = verifyParser k valueParser $ \s -> do
  79 --     expected <- val
  80 --     return $ bool (Left $ ValidatorError err) (Right Win) =<< f expected <$> mapLeft ParseError (parseOnly p s)
  81 --   where
  82 --     valueParser = string op *> skipSpace *> takeByteString
  83
  84 -- verifyParser :: (MonadIO m) => Key -> Parser a -> (a -> m (Either ValidationError Win)) -> Caveat -> m (Maybe (Either ValidationError Caveat))
  85 -- verifyParser k p f c = case parseOnly keyParser . cid $ c of
  86 --     Left _ -> return Nothing
  87 --     Right bs -> Just <$> case parseOnly p bs of
  88 --       Left err -> return $ Left $ ParseError err
  89 --       Right a -> fmap (const c) <$> f a
  90 --   where
  91 --     keyParser = string k *> skipSpace *> takeByteString
  92