{ mkDerivation, attoparsec, base, base64-bytestring, byteable
, bytestring, cereal, cryptohash, deepseq, either, hex, QuickCheck
-, stdenv, tasty, tasty-hunit, tasty-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 either hex
+ cryptohash deepseq either hex transformers
];
testDepends = [
attoparsec base base64-bytestring byteable bytestring cereal
name: hmacaroons
-version: 0.1.0.0
+version: 0.2.0.0
synopsis: Haskell implementation of macaroons
description:
= Macaroons: Pure haskell implementation of macaroons
other-modules: Crypto.Macaroon.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
-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 ./. {};
};
-{-# 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 (
- Verifier
- , 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 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.Either.Combinators
import Crypto.Macaroon.Internal
+import Crypto.Macaroon.Verifier.Internal
-type Verifier = Caveat -> Maybe (Either String Caveat)
-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 -> [Verifier] -> Macaroon -> Either String Macaroon
-verifyMacaroon secret verifiers m = verifySig secret m >>= verifyCavs verifiers
-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
+-- (.<) :: (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" (>=) ">="
--- TODO: define API
+verify :: MonadIO m => Key -> [Caveat -> m (Maybe (Either ValidationError Caveat))] -> 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
+
--- /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 Crypto.Macaroon.Internal
+
+data Win = Win
+
+data ValidationError = SigMismatch
+ | NoVerifier
+ | ParseError String
+ | ValidatorError String
+ deriving Show
+
+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
+
+
+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)
+
+
+verifyCavs :: MonadIO m
+ => [Caveat -> m (Maybe (Either ValidationError Caveat))]
+ -> 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 = 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)
sigs = testProperty "Signatures" $ \sm -> verifySig (secret sm) (macaroon sm) == Right (macaroon sm)
-- TODO: Re-do tests
+{-
+firstParty = testGroup "First party caveats" [
+ testGroup "Pure verifiers" [
+ testProperty "Zero caveat" $
+ forAll (sublistOf allvs) (\vs -> Right m == verifyCavs vs m)
+ , testProperty "One caveat" $
+ forAll (sublistOf allvs) (\vs -> disjoin [
+ 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 [
+ Right m3 == verifyCavs vs m3 .&&.
+ any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) .&&.
+ any (`elem` vs) [exV42,funTV43lte] .&&. (exV43 `notElem` vs)
+ , True === isLeft (verifyCavs vs m3)
+ ])
+ ]
+ , testGroup "Pure verifiers with sig" [
+ testProperty "Zero caveat" $
+ forAll (sublistOf allvs) (\vs -> Right m == verifyMacaroon sec vs m)
+ , testProperty "One caveat" $
+ forAll (sublistOf allvs) (\vs -> disjoin [
+ 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 [
+ Right m3 == verifyMacaroon sec vs m3 .&&.
+ any (`elem` vs) [exTC,funTCPre] .&&. (exTZ `notElem` vs) .&&.
+ any (`elem` vs) [exV42,funTV43lte] .&&. (exV43 `notElem` vs)
+ , True === isLeft (verifyMacaroon sec vs m3)
+ ])
+ ]
+ ]
+ -}
projects / github / fretlink / hmacaroons.git / commitdiff
