-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Crypto.Macaroon.Verifier
Copyright : (c) 2015 Julien Tanguy
-}
module Crypto.Macaroon.Verifier (
- Verified(..)
- , verifySig
- , verifyExact
- , verifyFun
- , verifyCavs
- -- , module Data.Attoparsec.ByteString
- , module Data.Attoparsec.ByteString.Char8
+ verify
+ , ValidationError(ValidatorError, ParseError)
+ -- , (.<), (.<=), (.==), (.>), (.>=)
+ -- , module Data.Attoparsec.ByteString.Char8
) where
-import Crypto.Hash
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Attoparsec.ByteString
+import Data.Attoparsec.ByteString.Char8
import Data.Bool
-import qualified Data.ByteString as BS
-import Data.Byteable
-import Data.Foldable
-import Data.Maybe
-import Data.Attoparsec.ByteString
-import Data.Attoparsec.ByteString.Char8
+import qualified Data.ByteString as BS
+import Data.Either.Combinators
import Crypto.Macaroon.Internal
+import Crypto.Macaroon.Verifier.Internal
--- | Opaque datatype for now. Might need more explicit errors
-data Verified = Ok | Failed deriving (Show,Eq)
-instance Monoid Verified where
- mempty = Ok
- mappend Ok Ok = Ok
- mappend _ _ = Failed
+-- (.<) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- (.<) = verifyOpBool "Greater or equal" (<) "<"
-type CaveatVerifier = Caveat -> Maybe Verified
+-- (.<=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- (.<=) = verifyOpBool "Strictly greater" (<=) "<="
-verifySig :: Key -> Macaroon -> Verified
-verifySig k m = bool Failed Ok $
- signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m)
- where
- hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256)
- derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256)
+-- (.==) :: (MonadIO m, Eq a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- (.==) = verifyOpBool "Not equal" (==) "="
+
+-- (.>) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- (.>) = verifyOpBool "Less or equal" (>) ">"
+
+-- (.>=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- (.>=) = verifyOpBool "Strictly less" (>=) ">="
-verifyCavs :: [Caveat -> Maybe Verified] -> Macaroon -> Verified
-verifyCavs verifiers m = mconcat $ map (\c -> mconcat . catMaybes $ map ($ c) verifiers) (caveats m)
-verifyExact :: (Eq a) => Key -> a -> Parser a -> Caveat -> Maybe Verified
-verifyExact k expected = verifyFun k (expected ==)
+verify :: MonadIO m => Key -> [Caveat -> m (Maybe (Either ValidationError Caveat))] -> Macaroon -> m (Either ValidationError Macaroon)
+verify secret verifiers m = join <$> forM (verifySig secret m) (verifyCavs verifiers)
-verifyFun :: Key -> (a -> Bool) -> Parser a -> Caveat -> Maybe Verified
-verifyFun key f parser cav = if key `BS.isPrefixOf` cid cav then
- case parseOnly kvparser (cid cav) of
- Right v -> (bool Failed Ok . f) <$> Just v
- Left _ -> Just Failed
- else Nothing
+
+-- verifyOpBool :: MonadIO m => String -> Parser a -> (a -> a -> Bool) -> BS.ByteString -> Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
+-- verifyOpBool err p f op k val = verifyParser k valueParser $ \s -> do
+-- expected <- val
+-- return $ bool (Left $ ValidatorError err) (Right Win) =<< f expected <$> mapLeft ParseError (parseOnly p s)
+-- where
+-- valueParser = string op *> skipSpace *> takeByteString
+
+verifyParser :: (MonadIO m) => Key -> Parser a -> (a -> m (Either ValidationError Win)) -> Caveat -> m (Maybe (Either ValidationError Caveat))
+verifyParser k p f c = case parseOnly keyParser . cid $ c of
+ Left _ -> return Nothing
+ Right bs -> Just <$> case parseOnly p bs of
+ Left err -> return $ Left $ ParseError err
+ Right a -> fmap (const c) <$> f a
where
- kvparser = do
- key <- string key
- skipSpace
- string "="
- skipSpace
- parser <* endOfInput
+ keyParser = string k *> skipSpace *> takeByteString
+