{ 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, 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 hex
+ cryptohash deepseq either hex transformers
];
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";
name: hmacaroons
-version: 0.1.0.0
+version: 0.3.0.0
synopsis: Haskell implementation of macaroons
description:
- = Macaroons: Pure haskell implementation of macaroons
- #macaroons-pure-haskell-implementation-of-macaroons#
- .
- Macaroons is a pure haskell implementation of macaroons. It aims to
+ Hmacaroons is a pure haskell implementation of macaroons. It aims to
provide compatibility at a serialized level with the
<https://github.com/rescrv/libmacaroons reference implementation> and
the <https://github.com/ecordell/pymacaroons python implementation>
.
__WARNING: This library has not been audited by security experts.__
- __There is no error handling at the moment, everyhting is silently accepted__
+ __There is no error handling at the moment, everything is silently accepted__
.
It is developed in the purpose of exploration purposes, and would need
much more attention if it were to be used in production.
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,
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
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
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,
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,
tasty-quickcheck >= 0.8,
QuickCheck >= 2.8,
- hmacaroons
+ deepseq >= 1.1,
+ transformers >= 0.4
-with (import <nixpkgs> {}).pkgs;
-let hspkgs = haskell-ng.packages.ghc7101.override {
+{ pkgs ? import <nixpkgs> {}, compiler ? "ghc7101" }:
+let hspkgs = pkgs.haskell.packages.${compiler}.override {
overrides = self: super: {
hmacaroons = self.callPackage ./. {};
};
-- * Types
Macaroon
, Caveat
+ , Secret
, Key
, Location
, Sig
, caveats
, signature
-- ** Caveats
- , caveatLoc
- , caveatId
- , caveatVId
+ , cl
+ , cid
+ , vid
-- * Create Macaroons
, create
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
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
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Crypto.Macaroon.Verifier
Copyright : (c) 2015 Julien Tanguy
-}
module Crypto.Macaroon.Verifier (
- Verified(..)
- , CaveatVerifier
- , (<???>)
- , 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 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 qualified Data.ByteString as BS
+import Data.Either.Combinators
import Crypto.Macaroon.Internal
+import Crypto.Macaroon.Verifier.Internal
+
+
+
+
+-- (.<) :: (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" (>=) ">="
+
+-- | 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)
+
+
+-- 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
-
--- | 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 $
- 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
--- /dev/null
+{-# 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 Data.Monoid
+
+import Crypto.Macaroon.Internal
+
+-- | 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
+ e `mappend` NoVerifier = e
+ SigMismatch `mappend` _ = SigMismatch
+ _ `mappend` SigMismatch = SigMismatch
+ (ValidatorError e) `mappend` (ParseError _) = ValidatorError e
+ (ParseError _) `mappend` (ValidatorError e) = ValidatorError e
+
+-- | Check that the given macaroon has a correct signature
+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)
+
+-- | Given a list of verifiers, verify each caveat of the given macaroon
+verifyCavs :: MonadIO m
+ => [Caveat -> m (Maybe (Either ValidationError ()))]
+ -> 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 = 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
+ gatherEithers vs = case partitionEithers . map validationToEither $ vs of
+ ([],_) -> Right m
+ (errs,_) -> Left (mconcat errs)
-}
module Crypto.Macaroon.Instances where
-import Control.Monad
+import Control.Monad
import Data.Byteable
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import Data.Hex
import Data.List
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)
module Crypto.Macaroon.Tests where
import Data.Byteable
-import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Char8 as B8
import Data.Hex
import Test.Tasty
import Test.Tasty.HUnit
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+{-|
+Copyright : (c) 2015 Julien Tanguy
+License : BSD3
+
+Maintainer : julien.tanguy@jhome.fr
+
+
+This test suite is based on the pymacaroons test suite:
+<https://github.com/ecordell/pymacaroons>
+-}
+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)
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
+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
- , firstParty
- ]
+tests = testGroup "Crypto.Macaroon.Verifier" [ ]
{-
- Test fixtures
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"
-
-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
+-- TODO: Re-do tests
+{-
firstParty = testGroup "First party caveats" [
testGroup "Pure verifiers" [
testProperty "Zero caveat" $
- forAll (sublistOf allvs) (\vs -> Ok == verifyCavs vs m)
+ forAll (sublistOf allvs) (\vs -> Right m == 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
+ 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 [
- Ok == verifyCavs vs m3 .&&.
+ Right m3 == verifyCavs vs m3 .&&.
any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) .&&.
any (`elem` vs) [exV42,funTV43lte] .&&. (exV43 `notElem` vs)
- , Failed === verifyCavs vs m3
+ , True === isLeft (verifyCavs vs m3)
])
]
, testGroup "Pure verifiers with sig" [
testProperty "Zero caveat" $
- forAll (sublistOf allvs) (\vs -> Ok == verifyMacaroon sec vs m)
+ forAll (sublistOf allvs) (\vs -> Right m == 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
+ 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 [
- Ok == verifyMacaroon sec vs m3 .&&.
+ Right m3 == 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
+ , True === isLeft (verifyMacaroon sec vs m3)
])
]
]
+ -}
-{-#LANGUAGE OverloadedStrings#-}
+{-# LANGUAGE OverloadedStrings #-}
module Sanity where
import Crypto.Hash
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
-import Data.Hex
-import Data.Byteable
+import Data.Byteable
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import Data.Hex
-import Test.Tasty
-import Test.Tasty.HUnit
+import Test.Tasty
+import Test.Tasty.HUnit
-import qualified Crypto.Macaroon.Tests
import qualified Crypto.Macaroon.Serializer.Base64.Tests
+import qualified Crypto.Macaroon.Tests
tests :: TestTree
tests = testGroup "Python HMAC Sanity check" [ checkKey
mac4 = toBytes (hmac mac3 "email = alice@example.org" :: HMAC SHA256)
-checkKey = testCase "Truncated key" $
+checkKey = testCase "Truncated key" $
key @?= "this is our super secret key; on"
-checkMac1 = testCase "HMAC key" $
+checkMac1 = testCase "HMAC key" $
"C60B4B3540BB1B2F2EF28D1C895691CC4A5E07A38A9D3B1C3379FB485293372F" @=? hex mac1
-checkMac2 = testCase "HMAC key account" $
+checkMac2 = testCase "HMAC key account" $
"5C933DC9A7D036DFCD1740B4F26D737397A1FF635EAC900F3226973503CAAAA5" @=? hex mac2
-checkMac3 = testCase "HMAC key account time" $
+checkMac3 = testCase "HMAC key account time" $
"7A559B20C8B607009EBCE138C200585E9D0DECA6D23B3EAD6C5E0BA6861D3858" @=? hex mac3
-checkMac4 = testCase "HMAC key account time email" $
+checkMac4 = testCase "HMAC key account time email" $
"E42BBB02A9A5A303483CB6295C497AE51AD1D5CB10003CBE548D907E7E62F5E4" @=? hex mac4
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
, Crypto.Macaroon.Tests.tests
, Crypto.Macaroon.Serializer.Base64.Tests.tests
, Crypto.Macaroon.Verifier.Tests.tests
+ , Crypto.Macaroon.Verifier.Internal.Tests.tests
]
projects / github / fretlink / hmacaroons.git / commitdiff
