From 7f9f7386fdbe8d19ef30ebd20939e67cc8bb145c Mon Sep 17 00:00:00 2001 From: Julien Tanguy Date: Sun, 16 Aug 2015 23:22:10 +0200 Subject: Basic validation functions Still needs testing [ci skip] --- src/Crypto/Macaroon/Verifier.hs | 81 ++++++++++++++++++-------------- src/Crypto/Macaroon/Verifier/Internal.hs | 74 +++++++++++++++++++++++++++++ 2 files changed, 121 insertions(+), 34 deletions(-) create mode 100644 src/Crypto/Macaroon/Verifier/Internal.hs (limited to 'src/Crypto') diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs index 713a971..7d5f094 100644 --- a/src/Crypto/Macaroon/Verifier.hs +++ b/src/Crypto/Macaroon/Verifier.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-| Module : Crypto.Macaroon.Verifier Copyright : (c) 2015 Julien Tanguy @@ -13,50 +16,60 @@ Portability : portable -} module Crypto.Macaroon.Verifier ( - Verifier - , verifyMacaroon - , verifySig - -- , verifyExact - -- , verifyFun - , module Data.Attoparsec.ByteString.Char8 - , verifyCavs + 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 Data.Byteable import qualified Data.ByteString as BS -import Data.Either -import Data.Either.Validation -import Data.Foldable -import Data.Function -import Data.Maybe -import Data.Traversable +import Data.Either.Combinators import Crypto.Macaroon.Internal +import Crypto.Macaroon.Verifier.Internal -type Verifier = Caveat -> Maybe (Either String Caveat) -verifySig :: Key -> Macaroon -> Either String Macaroon -verifySig k m = bool (Left "Signatures do not match") (Right m) $ - 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) -verifyMacaroon :: Key -> [Verifier] -> Macaroon -> Either String Macaroon -verifyMacaroon secret verifiers m = verifySig secret m >>= verifyCavs verifiers -verifyCavs :: [Verifier] -> Macaroon -> Either String Macaroon -verifyCavs verifiers m = case partitionEithers verifiedCaveats of - ([],_) -> Right m - (errs,_) -> Left (mconcat errs) - where - verifiedCaveats = map (\c -> defaultFail c $ foldMap (fmap eitherToValidation . ($c)) verifiers) $ caveats m - defaultFail c = maybe (Left ("No validation for this caveat: " ++ show c)) validationToEither +-- (.<) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat)) +-- (.<) = verifyOpBool "Greater or equal" (<) "<" + +-- (.<=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat)) +-- (.<=) = verifyOpBool "Strictly greater" (<=) "<=" + +-- (.==) :: (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" (>=) ">=" --- TODO: define API +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) + + +-- 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 + keyParser = string k *> skipSpace *> takeByteString + diff --git a/src/Crypto/Macaroon/Verifier/Internal.hs b/src/Crypto/Macaroon/Verifier/Internal.hs new file mode 100644 index 0000000..63d826d --- /dev/null +++ b/src/Crypto/Macaroon/Verifier/Internal.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-| +Module : Crypto.Macaroon.Verifier.Internal +Copyright : (c) 2015 Julien Tanguy +License : BSD3 + +Maintainer : julien.tanguy@jhome.fr +Stability : experimental +Portability : portable + + + +-} +module Crypto.Macaroon.Verifier.Internal where + +import Control.Monad +import Control.Monad.IO.Class +import Crypto.Hash +import Data.Bool +import Data.Byteable +import qualified Data.ByteString as BS +import Data.Either +import Data.Either.Validation +import Data.Foldable +import Data.Maybe + +import Crypto.Macaroon.Internal + +data Win = Win + +data ValidationError = SigMismatch + | NoVerifier + | ParseError String + | ValidatorError String + deriving Show + +instance Monoid ValidationError where + mempty = NoVerifier + NoVerifier `mappend` e = e + e `mappend` NoVerifier = e + SigMismatch `mappend` _ = SigMismatch + _ `mappend` SigMismatch = SigMismatch + (ValidatorError e) `mappend` (ParseError _) = ValidatorError e + (ParseError _) `mappend` (ValidatorError e) = ValidatorError e + + +verifySig :: Key -> Macaroon -> Either ValidationError Macaroon +verifySig k m = bool (Left SigMismatch) (Right m) $ + 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) + + +verifyCavs :: MonadIO m + => [Caveat -> m (Maybe (Either ValidationError Caveat))] + -> Macaroon + -> m (Either ValidationError Macaroon) +verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m) + where + {- + - validateCaveat :: Caveat -> m (Validation String Caveat) + - We can use fromJust here safely since we use a `Just Failure` as a + - starting value for the foldM. We are guaranteed to have a `Just something` + - from it. + -} + validateCaveat c = fromJust <$> foldM (\res v -> mappend res . fmap eitherToValidation <$> v c) (defErr c) verifiers + -- defErr :: Caveat -> Maybe (Validation String Caveat) + defErr c = Just $ Failure NoVerifier + -- gatherEithers :: [Validation String Caveat] -> Either String Caveat + gatherEithers vs = case partitionEithers . map validationToEither $ vs of + ([],_) -> Right m + (errs,_) -> Left (mconcat errs) -- cgit v1.2.3