show (MkMacaroon l i c s) = intercalate "\n" [
"location " ++ B8.unpack l
, "identifier " ++ B8.unpack i
- , concatMap show c
+ , intercalate "\n" (map show c)
, "signature " ++ B8.unpack (hex s)
]
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
{-|
Module : Crypto.Macaroon.Verifier
Copyright : (c) 2015 Julien Tanguy
-}
-module Crypto.Macaroon.Verifier where
+module Crypto.Macaroon.Verifier (
+ Verified(..)
+ , CaveatVerifier
+ , (<???>)
+ , verifyMacaroon
+ , verifySig
+ , verifyExact
+ , verifyFun
+ , module Data.Attoparsec.ByteString.Char8
+ , verifyCavs
+) where
import Crypto.Hash
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
import Crypto.Macaroon.Internal
-- | Opaque datatype for now. Might need more explicit errors
-data Result = Success | Failure deriving (Show,Eq)
+data Verified = Ok | Failed deriving (Show,Eq)
-verifySig :: Key -> Macaroon -> Result
-verifySig k m = bool Failure Success $
+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 $
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
+
+
+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 ==)
+
+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
-- | 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
instance Arbitrary Identifier where
arbitrary = Identifier . B8.pack <$>(scale (*3) . listOf1 . elements $ ['a'..'z'])
+newtype EquationLike = EquationLike { unEqlike :: BS.ByteString } deriving (Show)
+
+instance Arbitrary EquationLike where
+ arbitrary = do
+ keylen <- choose (3,8)
+ key <- B8.pack <$> vectorOf keylen (elements ['a'..'z'])
+ val <- B8.pack <$> (scale (*3) . listOf1 . elements $ ['a'..'z'])
+ return $ EquationLike (BS.concat [ key, " = ", val])
+
+
data SimpleMac = SimpleMac { secret :: BS.ByteString, macaroon :: Macaroon } deriving Show
instance Arbitrary SimpleMac where
secret <- unSecret <$> arbitrary
location <- unUrl <$> arbitrary
ident <- unIdent <$> arbitrary
- return $ SimpleMac secret (create secret ident location)
+ fpcavs <- listOf arbitrary
+ let mac = foldl (flip addFirstPartyCaveat) (create secret ident location) (map unEqlike fpcavs)
+ return $ SimpleMac secret mac
]
basicQC = testProperty "Reversibility" $
- forAll (macaroon <$> arbitrary) (\m -> deserialize (serialize m) == Right m)
+ \sm -> deserialize (serialize (macaroon sm)) == Right (macaroon sm)
m :: Macaroon
m = create secret key loc
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
import Crypto.Macaroon.Verifier
tests :: TestTree
tests = testGroup "Crypto.Macaroon.Verifier" [ sigs
+ , firstParty
]
+{-
+ - Test fixtures
+ -}
sec = B8.pack "this is our super secret key; only we should know it"
m :: Macaroon
m2 = addFirstPartyCaveat "test = caveat" m
m3 :: Macaroon
-m3 = addFirstPartyCaveat "test = acaveat" m
-
-sigs = testGroup "Signatures" [ basic
- , minted
- ]
-
-basic = testCase "Basic Macaroon Signature" $
- Success @=? verifySig sec m
-
-
-minted :: TestTree
-minted = testGroup "Macaroon with first party caveats" [ one
- , two
- ]
-one = testCase "One caveat" $
- Success @=? verifySig sec m2
-
-two = testCase "Two caveats" $
- Success @=? verifySig sec m3
-
+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"
+
+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 = 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
+ ])
+ ]
+ ]
projects / github / fretlink / hmacaroons.git / commitdiff
