From c830f7c2cf925ce340f4097d76ea2a3bc94cb4a6 Mon Sep 17 00:00:00 2001 From: Julien Tanguy Date: Wed, 8 Jul 2015 18:13:14 +0200 Subject: Rewrite Verifier with Validation --- default.nix | 8 ++-- hmacaroons.cabal | 2 + src/Crypto/Macaroon/Verifier.hs | 73 ++++++++++------------------------ test/Crypto/Macaroon/Verifier/Tests.hs | 59 +++++++-------------------- 4 files changed, 42 insertions(+), 100 deletions(-) diff --git a/default.nix b/default.nix index d968974..bd725a9 100644 --- a/default.nix +++ b/default.nix @@ -1,6 +1,6 @@ { mkDerivation, attoparsec, base, base64-bytestring, byteable -, bytestring, cereal, cryptohash, deepseq, hex, QuickCheck, stdenv -, tasty, tasty-hunit, tasty-quickcheck +, bytestring, cereal, cryptohash, deepseq, either, hex, QuickCheck +, stdenv, tasty, tasty-hunit, tasty-quickcheck }: mkDerivation { pname = "hmacaroons"; @@ -8,11 +8,11 @@ mkDerivation { src = ./.; buildDepends = [ attoparsec base base64-bytestring byteable bytestring cereal - cryptohash deepseq hex + cryptohash deepseq either hex ]; testDepends = [ attoparsec base base64-bytestring byteable bytestring cereal - cryptohash hex QuickCheck tasty tasty-hunit tasty-quickcheck + cryptohash either hex QuickCheck tasty tasty-hunit tasty-quickcheck ]; homepage = "https://github.com/jtanguy/hmacaroons"; description = "Haskell implementation of macaroons"; diff --git a/hmacaroons.cabal b/hmacaroons.cabal index b70a984..3aa338a 100644 --- a/hmacaroons.cabal +++ b/hmacaroons.cabal @@ -86,6 +86,7 @@ benchmark bench cereal >= 0.4, cryptohash >=0.11 && <0.12, -- cipher-aes >=0.2 && <0.3, + either >=4.4, hex >= 0.1, deepseq >= 1.1, criterion >= 1.1 @@ -102,6 +103,7 @@ test-suite test byteable >= 0.1 && <0.2, cereal >= 0.4, cryptohash >=0.11 && <0.12, + either >=4.4, hex >= 0.1, tasty >= 0.10, tasty-hunit >= 0.9, diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs index 02cb448..713a971 100644 --- a/src/Crypto/Macaroon/Verifier.hs +++ b/src/Crypto/Macaroon/Verifier.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} {-| Module : Crypto.Macaroon.Verifier Copyright : (c) 2015 Julien Tanguy @@ -13,79 +13,50 @@ Portability : portable -} module Crypto.Macaroon.Verifier ( - Verified(..) - , CaveatVerifier - , () + Verifier , verifyMacaroon , verifySig - , verifyExact - , verifyFun + -- , verifyExact + -- , verifyFun , module Data.Attoparsec.ByteString.Char8 , verifyCavs ) where import Crypto.Hash +import Data.Attoparsec.ByteString +import Data.Attoparsec.ByteString.Char8 import Data.Bool -import qualified Data.ByteString as BS 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.Attoparsec.ByteString -import Data.Attoparsec.ByteString.Char8 import Crypto.Macaroon.Internal +type Verifier = Caveat -> Maybe (Either String Caveat) --- | 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 - - -data CaveatVerifier = CV { vFun :: Caveat -> Maybe Verified , helpText :: String} - -instance Eq CaveatVerifier where - (==) = (==) `on` helpText - -instance Show CaveatVerifier where - show = helpText - -() :: (Caveat -> Maybe Verified) -> String -> CaveatVerifier -f t = CV f t - -verifySig :: Key -> Macaroon -> Verified -verifySig k m = bool Failed Ok $ +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 -> [CaveatVerifier] -> Macaroon -> Verified -verifyMacaroon secret verifiers m = verifySig secret m `mappend` verifyCavs verifiers m - +verifyMacaroon :: Key -> [Verifier] -> Macaroon -> Either String Macaroon +verifyMacaroon secret verifiers m = verifySig secret m >>= verifyCavs verifiers -verifyCavs :: [CaveatVerifier] -> Macaroon -> Verified -verifyCavs verifiers m = foldMap (\c -> fromMaybe Failed $ foldMap (($ c) . vFun) verifiers) (caveats m) +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 -verifyExact :: (Eq a) => Key -> a -> Parser a -> Caveat -> Maybe Verified -verifyExact k expected = verifyFun k (expected ==) -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 - where - kvparser = do - key <- string key - skipSpace - string "=" - skipSpace - parser <* endOfInput +-- TODO: define API diff --git a/test/Crypto/Macaroon/Verifier/Tests.hs b/test/Crypto/Macaroon/Verifier/Tests.hs index 101fa26..4a9295f 100644 --- a/test/Crypto/Macaroon/Verifier/Tests.hs +++ b/test/Crypto/Macaroon/Verifier/Tests.hs @@ -16,7 +16,8 @@ import Data.List import qualified Data.ByteString.Char8 as B8 import Test.Tasty -- import Test.Tasty.HUnit -import Test.Tasty.QuickCheck +import Test.Tasty.QuickCheck hiding (Success, Failure) +import Data.Either import Crypto.Macaroon import Crypto.Macaroon.Verifier @@ -25,7 +26,6 @@ import Crypto.Macaroon.Instances tests :: TestTree tests = testGroup "Crypto.Macaroon.Verifier" [ sigs - , firstParty ] {- @@ -45,52 +45,21 @@ m2 = addFirstPartyCaveat "test = caveat" m m3 :: Macaroon m3 = addFirstPartyCaveat "value = 42" m2 -exTC = verifyExact "test" "caveat" (many' letter_ascii) "test = caveat" -exTZ = verifyExact "test" "bleh" (many' letter_ascii) "test = bleh" -exV42 = verifyExact "value" 42 decimal "value = 42" -exV43 = verifyExact "value" 43 decimal "value = 43" +-- 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" ("cav" `isPrefixOf`) (many' letter_ascii) "test startsWith cav" -funTV43lte = verifyFun "value" (<= 43) decimal "value <= 43" +-- 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] +-- allvs = [exTC, exTZ, exV42, exV43, funTCPre, funTV43lte] {- - Tests -} -sigs = testProperty "Signatures" $ \sm -> verifySig (secret sm) (macaroon sm) == Ok - -firstParty = testGroup "First party caveats" [ - testGroup "Pure verifiers" [ - testProperty "Zero caveat" $ - forAll (sublistOf allvs) (\vs -> Ok == verifyCavs vs m) - , testProperty "One caveat" $ - forAll (sublistOf allvs) (\vs -> disjoin [ - Ok == verifyCavs vs m2 .&&. any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) - , Failed === verifyCavs vs m2 - ]) - , testProperty "Two Exact" $ - forAll (sublistOf allvs) (\vs -> disjoin [ - Ok == verifyCavs vs m3 .&&. - any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) .&&. - any (`elem` vs) [exV42,funTV43lte] .&&. (exV43 `notElem` vs) - , Failed === verifyCavs vs m3 - ]) - ] - , testGroup "Pure verifiers with sig" [ - testProperty "Zero caveat" $ - forAll (sublistOf allvs) (\vs -> Ok == verifyMacaroon sec vs m) - , testProperty "One caveat" $ - forAll (sublistOf allvs) (\vs -> disjoin [ - Ok == verifyMacaroon sec vs m2 .&&. any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) - , Failed === verifyMacaroon sec vs m2 - ]) - , testProperty "Two Exact" $ - forAll (sublistOf allvs) (\vs -> disjoin [ - Ok == verifyMacaroon sec vs m3 .&&. - any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) .&&. - any (`elem` vs) [exV42,funTV43lte] .&&. (exV43 `notElem` vs) - , Failed === verifyMacaroon sec vs m3 - ]) - ] - ] +sigs = testProperty "Signatures" $ \sm -> verifySig (secret sm) (macaroon sm) == Right (macaroon sm) + +-- TODO: Re-do tests -- cgit v1.2.3