From 86f3882318d323d1920ca1c7da6e816f0ed376da Mon Sep 17 00:00:00 2001 From: Julien Tanguy Date: Mon, 17 Aug 2015 17:38:24 +0200 Subject: [PATCH] Change verifier api and split Verifier module - Added haddocks --- hmacaroons.cabal | 10 +++--- src/Crypto/Macaroon.hs | 21 +++-------- src/Crypto/Macaroon/Internal.hs | 6 +++- src/Crypto/Macaroon/Verifier.hs | 35 +++++++++++++------ src/Crypto/Macaroon/Verifier/Internal.hs | 30 +++++++++------- test/Crypto/Macaroon/Instances.hs | 6 ++-- .../Macaroon/Verifier/Internal/Tests.hs | 30 ++++++++++++++++ test/Crypto/Macaroon/Verifier/Tests.hs | 28 ++++----------- test/main.hs | 10 +++--- 9 files changed, 104 insertions(+), 72 deletions(-) create mode 100644 test/Crypto/Macaroon/Verifier/Internal/Tests.hs diff --git a/hmacaroons.cabal b/hmacaroons.cabal index 9424f22..83b2cd7 100644 --- a/hmacaroons.cabal +++ b/hmacaroons.cabal @@ -1,5 +1,5 @@ name: hmacaroons -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Haskell implementation of macaroons description: Hmacaroons is a pure haskell implementation of macaroons. It aims to @@ -51,10 +51,11 @@ source-repository head library exposed-modules: Crypto.Macaroon - Crypto.Macaroon.Binder + -- Crypto.Macaroon.Binder Crypto.Macaroon.Serializer.Base64 Crypto.Macaroon.Verifier other-modules: Crypto.Macaroon.Internal + Crypto.Macaroon.Verifier.Internal build-depends: base >=4 && < 5, attoparsec >=0.12, transformers >= 0.4, @@ -93,7 +94,7 @@ benchmark bench test-suite test default-language: Haskell2010 type: exitcode-stdio-1.0 - hs-source-dirs: test + hs-source-dirs: src, test main-is: main.hs build-depends: base >= 4 && <5, attoparsec >=0.12, @@ -108,4 +109,5 @@ test-suite test tasty-hunit >= 0.9, tasty-quickcheck >= 0.8, QuickCheck >= 2.8, - hmacaroons + deepseq >= 1.1, + transformers >= 0.4 diff --git a/src/Crypto/Macaroon.hs b/src/Crypto/Macaroon.hs index bfcf8df..c9c8c21 100644 --- a/src/Crypto/Macaroon.hs +++ b/src/Crypto/Macaroon.hs @@ -23,6 +23,7 @@ module Crypto.Macaroon ( -- * Types Macaroon , Caveat + , Secret , Key , Location , Sig @@ -33,9 +34,9 @@ module Crypto.Macaroon ( , caveats , signature -- ** Caveats - , caveatLoc - , caveatId - , caveatVId + , cl + , cid + , vid -- * Create Macaroons , create @@ -54,23 +55,11 @@ import qualified Data.ByteString.Char8 as B8 import Crypto.Macaroon.Internal -- | Create a Macaroon from its key, identifier and location -create :: Key -> Key -> Location -> Macaroon +create :: Secret -> Key -> Location -> Macaroon create secret ident loc = MkMacaroon loc ident [] (toBytes (hmac derivedKey ident :: HMAC SHA256)) where derivedKey = toBytes (hmac "macaroons-key-generator" secret :: HMAC SHA256) --- | Caveat target location -caveatLoc :: Caveat -> Location -caveatLoc = cl - --- | Caveat identifier -caveatId :: Caveat -> Key -caveatId = cid - --- | Caveat verification identifier -caveatVId :: Caveat -> Key -caveatVId = vid - -- | Inspect a macaroon's contents. For debugging purposes. inspect :: Macaroon -> String inspect = show diff --git a/src/Crypto/Macaroon/Internal.hs b/src/Crypto/Macaroon/Internal.hs index 2f56512..d6e80d3 100644 --- a/src/Crypto/Macaroon/Internal.hs +++ b/src/Crypto/Macaroon/Internal.hs @@ -23,7 +23,11 @@ import qualified Data.ByteString.Char8 as B8 import Data.Hex import Data.List --- |Type alias for Macaroons and Caveat keys and identifiers + +-- |Type alias for Macaroons secret keys +type Secret = BS.ByteString + +-- |Type alias for Macaroons and Caveat and identifiers type Key = BS.ByteString -- |Type alias for Macaroons and Caveat locations diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs index 7d5f094..a739437 100644 --- a/src/Crypto/Macaroon/Verifier.hs +++ b/src/Crypto/Macaroon/Verifier.hs @@ -52,8 +52,23 @@ import Crypto.Macaroon.Verifier.Internal -- (.>=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat)) -- (.>=) = verifyOpBool "Strictly less" (>=) ">=" - -verify :: MonadIO m => Key -> [Caveat -> m (Maybe (Either ValidationError Caveat))] -> Macaroon -> m (Either ValidationError Macaroon) +-- | Verify a Macaroon's signature and caveats, given the corresponding Secret +-- and verifiers. +-- +-- A verifier is a function of type +-- @'MonadIO' m => 'Caveat' -> m ('Maybe' ('Either' 'ValidatorError' 'Caveat'))@. +-- +-- It should return: +-- +-- * 'Nothing' if the caveat is not related to the verifier +-- (for instance a time verifier is given an action caveat); +-- * 'Just' ('Left' ('ParseError' reason)) if the verifier is related to the +-- caveat, but failed to parse it completely; +-- * 'Just' ('Left' ('ValidatorError' reason)) if the verifier is related to the +-- caveat, parsed it and invalidated it; +-- * 'Just' ('Right' '()') if the verifier has successfully verified the +-- given caveat +verify :: MonadIO m => Secret -> [Caveat -> m (Maybe (Either ValidationError ()))] -> Macaroon -> m (Either ValidationError Macaroon) verify secret verifiers m = join <$> forM (verifySig secret m) (verifyCavs verifiers) @@ -64,12 +79,12 @@ verify secret verifiers m = join <$> forM (verifySig secret m) (verifyCavs verif -- 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 +-- 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 index b65b62d..2af55d3 100644 --- a/src/Crypto/Macaroon/Verifier/Internal.hs +++ b/src/Crypto/Macaroon/Verifier/Internal.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-| Module : Crypto.Macaroon.Verifier.Internal Copyright : (c) 2015 Julien Tanguy @@ -19,22 +19,26 @@ import Control.Monad.IO.Class import Crypto.Hash import Data.Bool import Data.Byteable -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Data.Either import Data.Either.Validation import Data.Foldable import Data.Maybe +import Data.Monoid import Crypto.Macaroon.Internal -data Win = Win - -data ValidationError = SigMismatch - | NoVerifier - | ParseError String - | ValidatorError String - deriving Show +-- | Type representing different validation errors. +-- Only 'ParseError' and 'ValidatorError' are exported, 'SigMismatch' and +-- 'NoVerifier' are used internally and should not be used by the user +data ValidationError = SigMismatch -- ^ Signatures do not match + | NoVerifier -- ^ No verifier can handle a given caveat + | ParseError String -- ^ A verifier had a parse error + | ValidatorError String -- ^ A verifier failed + deriving (Show,Eq) +-- | The 'Monoid' instance is written so 'SigMismatch' is an annihilator, +-- and 'NoVerifier' is the identity element instance Monoid ValidationError where mempty = NoVerifier NoVerifier `mappend` e = e @@ -52,9 +56,9 @@ verifySig k m = bool (Left SigMismatch) (Right m) $ hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256) derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256) - +-- | Given a list of verifiers, verify each caveat of the given macaroon verifyCavs :: MonadIO m - => [Caveat -> m (Maybe (Either ValidationError Caveat))] + => [Caveat -> m (Maybe (Either ValidationError ()))] -> Macaroon -> m (Either ValidationError Macaroon) verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m) @@ -65,7 +69,7 @@ verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m) - 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 + validateCaveat c = fmap (const 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 diff --git a/test/Crypto/Macaroon/Instances.hs b/test/Crypto/Macaroon/Instances.hs index 9c89857..6348c56 100644 --- a/test/Crypto/Macaroon/Instances.hs +++ b/test/Crypto/Macaroon/Instances.hs @@ -32,10 +32,10 @@ instance Arbitrary Url where domain <- elements [".com",".net"] return . Url . B8.pack $ (protocol ++ name ++ domain) -newtype Secret = Secret { unSecret :: BS.ByteString } deriving (Show) +newtype BSSecret = BSSecret { unSecret :: BS.ByteString } deriving (Show) -instance Arbitrary Secret where - arbitrary = Secret . B8.pack <$> scale (*3) arbitrary +instance Arbitrary BSSecret where + arbitrary = BSSecret . B8.pack <$> scale (*3) arbitrary newtype Identifier = Identifier { unIdent :: BS.ByteString } deriving (Show) diff --git a/test/Crypto/Macaroon/Verifier/Internal/Tests.hs b/test/Crypto/Macaroon/Verifier/Internal/Tests.hs new file mode 100644 index 0000000..cd75118 --- /dev/null +++ b/test/Crypto/Macaroon/Verifier/Internal/Tests.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Copyright : (c) 2015 Julien Tanguy +License : BSD3 + +Maintainer : julien.tanguy@jhome.fr + + +This test suite is based on the pymacaroons test suite: + +-} +module Crypto.Macaroon.Verifier.Internal.Tests where + +import qualified Data.ByteString.Char8 as B8 +import Data.List +import Test.Tasty +-- import Test.Tasty.HUnit +import Data.Either +import Test.Tasty.QuickCheck hiding (Failure, Success) + +import Crypto.Macaroon +import Crypto.Macaroon.Verifier.Internal + +import Crypto.Macaroon.Instances + +tests :: TestTree +tests = testGroup "Crypto.Macaroon.Verifier.Internal" [ sigs + ] + +sigs = testProperty "Signatures" $ \sm -> verifySig (secret sm) (macaroon sm) == Right (macaroon sm) diff --git a/test/Crypto/Macaroon/Verifier/Tests.hs b/test/Crypto/Macaroon/Verifier/Tests.hs index 670c991..b6220eb 100644 --- a/test/Crypto/Macaroon/Verifier/Tests.hs +++ b/test/Crypto/Macaroon/Verifier/Tests.hs @@ -12,21 +12,20 @@ This test suite is based on the pymacaroons test suite: module Crypto.Macaroon.Verifier.Tests where -import Data.List -import qualified Data.ByteString.Char8 as B8 -import Test.Tasty +import qualified Data.ByteString.Char8 as B8 +import Data.List +import Test.Tasty -- import Test.Tasty.HUnit -import Test.Tasty.QuickCheck hiding (Success, Failure) -import Data.Either +import Data.Either +import Test.Tasty.QuickCheck hiding (Failure, Success) import Crypto.Macaroon import Crypto.Macaroon.Verifier -import Crypto.Macaroon.Instances +import Crypto.Macaroon.Instances tests :: TestTree -tests = testGroup "Crypto.Macaroon.Verifier" [ sigs - ] +tests = testGroup "Crypto.Macaroon.Verifier" [ ] {- - Test fixtures @@ -45,22 +44,9 @@ m2 = addFirstPartyCaveat "test = caveat" m m3 :: Macaroon m3 = addFirstPartyCaveat "value = 42" m2 --- exTC = verifyExact "test" "caveat" (many' letter_ascii) --- exTZ = verifyExact "test" "bleh" (many' letter_ascii) --- exV42 = verifyExact "value" 42 decimal --- exV43 = verifyExact "value" 43 decimal - --- funTCPre = verifyFun "test" (string "test = " *> many' letter_ascii) --- (\e -> if "cav" `isPrefixOf` e then Right e else Left "Does not start with cav" ) --- funTV43lte = verifyFun "value" (string "value = " *> decimal) --- (\v -> if v <= 43 then Right v else Left "Greater than 43") - --- allvs = [exTC, exTZ, exV42, exV43, funTCPre, funTV43lte] - {- - Tests -} -sigs = testProperty "Signatures" $ \sm -> verifySig (secret sm) (macaroon sm) == Right (macaroon sm) -- TODO: Re-do tests {- diff --git a/test/main.hs b/test/main.hs index 3edbe54..67ebcd5 100644 --- a/test/main.hs +++ b/test/main.hs @@ -1,12 +1,13 @@ module Main where -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty +import Test.Tasty.HUnit -import qualified Sanity -import qualified Crypto.Macaroon.Tests import qualified Crypto.Macaroon.Serializer.Base64.Tests +import qualified Crypto.Macaroon.Tests +import qualified Crypto.Macaroon.Verifier.Internal.Tests import qualified Crypto.Macaroon.Verifier.Tests +import qualified Sanity main = defaultMain tests @@ -15,5 +16,6 @@ tests = testGroup "Tests" [ Sanity.tests , Crypto.Macaroon.Tests.tests , Crypto.Macaroon.Serializer.Base64.Tests.tests , Crypto.Macaroon.Verifier.Tests.tests + , Crypto.Macaroon.Verifier.Internal.Tests.tests ] -- 2.41.0