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] --- default.nix | 6 +-- hmacaroons.cabal | 4 +- shell.nix | 4 +- src/Crypto/Macaroon/Verifier.hs | 81 ++++++++++++++++++-------------- src/Crypto/Macaroon/Verifier/Internal.hs | 74 +++++++++++++++++++++++++++++ test/Crypto/Macaroon/Verifier/Tests.hs | 36 ++++++++++++++ 6 files changed, 165 insertions(+), 40 deletions(-) create mode 100644 src/Crypto/Macaroon/Verifier/Internal.hs diff --git a/default.nix b/default.nix index bd725a9..b1404ef 100644 --- a/default.nix +++ b/default.nix @@ -1,14 +1,14 @@ { mkDerivation, attoparsec, base, base64-bytestring, byteable , bytestring, cereal, cryptohash, deepseq, either, hex, QuickCheck -, stdenv, tasty, tasty-hunit, tasty-quickcheck +, stdenv, tasty, tasty-hunit, tasty-quickcheck, transformers }: mkDerivation { pname = "hmacaroons"; - version = "0.1.0.0"; + version = "0.2.0.0"; src = ./.; buildDepends = [ attoparsec base base64-bytestring byteable bytestring cereal - cryptohash deepseq either hex + cryptohash deepseq either hex transformers ]; testDepends = [ attoparsec base base64-bytestring byteable bytestring cereal diff --git a/hmacaroons.cabal b/hmacaroons.cabal index 3aa338a..7b5a0dd 100644 --- a/hmacaroons.cabal +++ b/hmacaroons.cabal @@ -1,5 +1,5 @@ name: hmacaroons -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Haskell implementation of macaroons description: = Macaroons: Pure haskell implementation of macaroons @@ -60,12 +60,14 @@ library other-modules: Crypto.Macaroon.Internal build-depends: base >=4 && < 5, attoparsec >=0.12, + transformers >= 0.4, bytestring >=0.10, base64-bytestring >= 1.0, byteable >= 0.1 && <0.2, cereal >= 0.4, cryptohash >=0.11 && <0.12, either >=4.4, + -- nonce, -- cipher-aes >=0.2 && <0.3, deepseq >= 1.1, hex >= 0.1 diff --git a/shell.nix b/shell.nix index 07952fc..3846dd5 100644 --- a/shell.nix +++ b/shell.nix @@ -1,5 +1,5 @@ -with (import {}).pkgs; -let hspkgs = haskell-ng.packages.ghc7101.override { +{ pkgs ? import {}, compiler ? "ghc7101" }: +let hspkgs = pkgs.haskell.packages.${compiler}.override { overrides = self: super: { hmacaroons = self.callPackage ./. {}; }; 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) diff --git a/test/Crypto/Macaroon/Verifier/Tests.hs b/test/Crypto/Macaroon/Verifier/Tests.hs index 4a9295f..670c991 100644 --- a/test/Crypto/Macaroon/Verifier/Tests.hs +++ b/test/Crypto/Macaroon/Verifier/Tests.hs @@ -63,3 +63,39 @@ m3 = addFirstPartyCaveat "value = 42" m2 sigs = testProperty "Signatures" $ \sm -> verifySig (secret sm) (macaroon sm) == Right (macaroon sm) -- TODO: Re-do tests +{- +firstParty = testGroup "First party caveats" [ + testGroup "Pure verifiers" [ + testProperty "Zero caveat" $ + forAll (sublistOf allvs) (\vs -> Right m == verifyCavs vs m) + , testProperty "One caveat" $ + forAll (sublistOf allvs) (\vs -> disjoin [ + Right m2 == verifyCavs vs m2 .&&. any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) + , True === isLeft( verifyCavs vs m2) + ]) + , testProperty "Two Exact" $ + forAll (sublistOf allvs) (\vs -> disjoin [ + Right m3 == verifyCavs vs m3 .&&. + any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) .&&. + any (`elem` vs) [exV42,funTV43lte] .&&. (exV43 `notElem` vs) + , True === isLeft (verifyCavs vs m3) + ]) + ] + , testGroup "Pure verifiers with sig" [ + testProperty "Zero caveat" $ + forAll (sublistOf allvs) (\vs -> Right m == verifyMacaroon sec vs m) + , testProperty "One caveat" $ + forAll (sublistOf allvs) (\vs -> disjoin [ + Right m2 == verifyMacaroon sec vs m2 .&&. any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) + , True === isLeft (verifyMacaroon sec vs m2) + ]) + , testProperty "Two Exact" $ + forAll (sublistOf allvs) (\vs -> disjoin [ + Right m3 == verifyMacaroon sec vs m3 .&&. + any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) .&&. + any (`elem` vs) [exV42,funTV43lte] .&&. (exV43 `notElem` vs) + , True === isLeft (verifyMacaroon sec vs m3) + ]) + ] + ] + -} -- cgit v1.2.3