From: Julien Tanguy Date: Sat, 16 May 2015 00:12:14 +0000 (+0200) Subject: Fix caveat verification X-Git-Url: https://git.immae.eu/?a=commitdiff_plain;h=90695615c54b5939d7286e777cb1b19a221616b9;p=github%2Ffretlink%2Fhmacaroons.git Fix caveat verification QuickCheck properties > HUnit tests --- diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs index 012d156..4eedff5 100644 --- a/src/Crypto/Macaroon/Verifier.hs +++ b/src/Crypto/Macaroon/Verifier.hs @@ -14,6 +14,8 @@ Portability : portable -} module Crypto.Macaroon.Verifier ( Verified(..) + , CaveatVerifier(..) + , () , verifySig , verifyExact , verifyFun @@ -28,7 +30,9 @@ import Data.Bool import qualified Data.ByteString as BS import Data.Byteable import Data.Foldable +import Data.Function import Data.Maybe +import Data.Traversable import Data.Attoparsec.ByteString import Data.Attoparsec.ByteString.Char8 @@ -44,7 +48,16 @@ instance Monoid Verified where mappend _ _ = Failed -type CaveatVerifier = Caveat -> Maybe Verified +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 $ @@ -53,8 +66,8 @@ verifySig k m = bool Failed Ok $ hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256) derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256) -verifyCavs :: [Caveat -> Maybe Verified] -> Macaroon -> Verified -verifyCavs verifiers m = mconcat $ map (\c -> mconcat . catMaybes $ map ($ c) verifiers) (caveats m) +verifyCavs :: [CaveatVerifier] -> Macaroon -> Verified +verifyCavs verifiers m = foldMap (\c -> fromMaybe Failed $ foldMap (($ c) . vFun) verifiers) (caveats m) verifyExact :: (Eq a) => Key -> a -> Parser a -> Caveat -> Maybe Verified verifyExact k expected = verifyFun k (expected ==) diff --git a/test/Crypto/Macaroon/Instances.hs b/test/Crypto/Macaroon/Instances.hs index 17044a0..c82bbd3 100644 --- a/test/Crypto/Macaroon/Instances.hs +++ b/test/Crypto/Macaroon/Instances.hs @@ -26,9 +26,16 @@ import Crypto.Macaroon -- | Adjust the size parameter, by transforming it with the given -- function. +-- Copied over from QuickCheck 2.8 scale :: (Int -> Int) -> Gen a -> Gen a scale f g = sized (\n -> resize (f n) g) + +-- | Generates a random subsequence of the given list. +-- Copied over from QuickCheck 2.8 +sublistOf :: [a] -> Gen [a] +sublistOf = filterM (\_ -> choose (False, True)) + newtype Url = Url { unUrl :: BS.ByteString } deriving (Show) instance Arbitrary Url where diff --git a/test/Crypto/Macaroon/Verifier/Tests.hs b/test/Crypto/Macaroon/Verifier/Tests.hs index 54c8db1..5f09bca 100644 --- a/test/Crypto/Macaroon/Verifier/Tests.hs +++ b/test/Crypto/Macaroon/Verifier/Tests.hs @@ -15,7 +15,7 @@ module Crypto.Macaroon.Verifier.Tests where import Data.List import qualified Data.ByteString.Char8 as B8 import Test.Tasty -import Test.Tasty.HUnit +-- import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Crypto.Macaroon @@ -25,7 +25,7 @@ import Crypto.Macaroon.Instances tests :: TestTree tests = testGroup "Crypto.Macaroon.Verifier" [ sigs - , exactCavs + , firstParty ] {- @@ -45,49 +45,36 @@ m2 = addFirstPartyCaveat "test = caveat" m m3 :: Macaroon m3 = addFirstPartyCaveat "value = 42" m2 -exVerifiers = [ verifyExact "test" "caveat" (many' letter_ascii) - , verifyExact "value" 42 decimal - ] -exVerifiers' = [ verifyExact "test" "caveat" (many' letter_ascii) - , verifyExact "value" 43 decimal - ] -funVerifiers = [ verifyFun "test" ("cav" `isPrefixOf`) (many' letter_ascii) - , verifyFun "value" (<= 43) decimal - ] +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" + +funTCPre = verifyFun "test" ("cav" `isPrefixOf`) (many' letter_ascii) "test startsWith cav" +funTV43lte = verifyFun "value" (<= 43) decimal "value <= 43" + +allvs = [exTC, exTZ, exV42, exV43, funTCPre, funTV43lte] {- - Tests -} -sigs = testGroup "Signatures" [ basic - , one - , two - ] - -basic = testGroup "Basic Macaroon" [ none , sigQC ] - -none = testCase "No caveat" $ - Ok @=? verifySig sec m - -sigQC = testProperty "Random" $ - \sm -> verifySig (secret sm) (macaroon sm) == Ok - -one = testCase "Macaroon with one caveat" $ - Ok @=? verifySig sec m2 - -two = testCase "Macaroon with two caveats" $ - Ok @=? verifySig sec m3 - -exactCavs = testGroup "Exact Caveats" [ - testGroup "Ignoring non-relevant" [ - testCase "Zero caveat" $ Ok @=? verifyCavs exVerifiers m - , testCase "One caveat" $ Ok @=? verifyCavs exVerifiers' m2 +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 + ]) ] - , testCase "One caveat win" $ Ok @=? verifyCavs exVerifiers m2 - , testCase "Two caveat win" $ Ok @=? verifyCavs exVerifiers m3 - , testCase "Two caveat fail" $ Failed @=? verifyCavs exVerifiers' m3 - ] - -funCavs = testGroup "Function Caveats" [ - testCase "One caveat win" $ Ok @=? verifyCavs funVerifiers m2 - , testCase "Two caveat win" $ Ok @=? verifyCavs funVerifiers m3 - ] + ]