macaroon-shop 0.1.0.0 → 0.1.0.1
raw patch · 10 files changed
+463/−474 lines, 10 filesdep +cryptondep +macaroon-shopdep −cryptonitedep ~basedep ~bytestringdep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies added: crypton, macaroon-shop
Dependencies removed: cryptonite
Dependency ranges changed: base, bytestring, containers, hedgehog, memory, saltine, transformers
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−2
- LICENSE +28/−0
- macaroon-shop.cabal +20/−21
- src/Authorize/Macaroon.hs +82/−80
- src/Authorize/Macaroon/Crypto.hs +55/−51
- src/Authorize/Macaroon/Serialize.hs +21/−33
- src/Authorize/Macaroon/Types.hs +73/−82
- src/Authorize/Macaroon/Verify.hs +75/−69
- test/Authorize/Macaroon/Gen.hs +35/−52
- test/Main.hs +70/−84
CHANGELOG.md view
@@ -1,5 +1,7 @@-# Revision history for macaroon-shop+# 0.1.0.1 -## 0.1.0.0 -- 2020-03-07+Relax dependencies, change license++# 0.1.0.0 -- 2020-03-07 First release
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright 2021 Ian Shipman++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
macaroon-shop.cabal view
@@ -1,41 +1,41 @@ cabal-version: 2.4 name: macaroon-shop-version: 0.1.0.0+version: 0.1.0.1 synopsis: A toolkit for working with macaroons-license: ISC+license: BSD-3-Clause+license-file: LICENSE author: Ian Shipman maintainer: ics@gambolingpangolin.com homepage: https://github.com/GambolingPangolin/macaroon-shop extra-source-files: CHANGELOG.md - common core- default-language: Haskell2010+ default-language: GHC2021 ghc-options: -Wall build-depends:- base ^>=4.12.0.0- , bytestring ^>=0.10- , bytes ^>=0.17- , cereal ^>=0.5- , containers ^>=0.6- , cryptonite ^>=0.26- , memory >=0.14- , saltine ^>=0.1- , transformers ^>=0.5+ base >=4.12 && <5+ , bytestring >=0.10 && <0.13+ , bytes ^>=0.17+ , cereal ^>=0.5+ , containers >=0.6 && <0.8+ , crypton >=1.0 && <1.1+ , memory >=0.14 && <0.19+ , saltine ^>=0.2+ , transformers >=0.5 && <0.7 +library+ import: core+ hs-source-dirs: src/+ other-modules: Authorize.Macaroon.Crypto Authorize.Macaroon.Serialize Authorize.Macaroon.Types Authorize.Macaroon.Verify -library- import: core- default-language: Haskell2010- hs-source-dirs: src/ exposed-modules: Authorize.Macaroon @@ -45,15 +45,14 @@ main-is: Main.hs hs-source-dirs:- src/ test/ ghc-options:- -threaded -O2+ -threaded other-modules:- Authorize.Macaroon Authorize.Macaroon.Gen build-depends:- hedgehog ^>=1.0+ hedgehog >=1.0 && <1.6+ , macaroon-shop
src/Authorize/Macaroon.hs view
@@ -8,116 +8,118 @@ -- <http://theory.stanford.edu/~ataly/Papers/macaroons.pdf>. The -- serialization, cryptography, and validation semantics are compatible with -- go-macaroons <https://github.com/go-macaroon/macaroon>.-module Authorize.Macaroon- (+module Authorize.Macaroon ( -- * Types-- MacaroonId (..)- , Macaroon- , SealedMacaroon (..)-- , Key (..)- , Location+ MacaroonId (..),+ Macaroon,+ SealedMacaroon (..),+ Key (..),+ Location, -- * Core interface-- , createMacaroon- , addFirstPartyCaveat- , addThirdPartyCaveat- , extractThirdPartyCaveats- , sealMacaroon-- , createDischargeMacaroon-- , verify- , VerificationFailure (..)- ) where--import Data.ByteString (ByteString)-import Data.List (foldl')-import Data.Maybe (isJust)--import Authorize.Macaroon.Crypto-import Authorize.Macaroon.Types-import Authorize.Macaroon.Verify+ createMacaroon,+ addFirstPartyCaveat,+ addThirdPartyCaveat,+ extractThirdPartyCaveats,+ sealMacaroon,+ createDischargeMacaroon,+ verify,+ VerificationFailure (..),+) where +import Authorize.Macaroon.Crypto (+ bindForRequest,+ createSignature,+ deriveKey,+ encryptKey,+ updateSignature,+ )+import Authorize.Macaroon.Types (+ Caveat (Caveat, caveatContent, caveatKeyId),+ Key (..),+ Location,+ Macaroon (Macaroon, caveats, macaroonSignature),+ MacaroonId (..),+ SealedMacaroon (..),+ )+import Authorize.Macaroon.Verify (+ VerificationFailure (..),+ verify,+ )+import Data.ByteString (ByteString)+import Data.List (foldl')+import Data.Maybe (isJust) -- | Mint a macaroon-createMacaroon- :: Key- -- ^ signing key- -> MacaroonId- -- ^ identifier for this macaroon- -> Location- -- ^ location hint- -> [ByteString]- -- ^ first party caveats to include- -> Macaroon+createMacaroon ::+ -- | signing key+ Key ->+ -- | identifier for this macaroon+ MacaroonId ->+ -- | location hint+ Location ->+ -- | first party caveats to include+ [ByteString] ->+ Macaroon createMacaroon k mid loc = foldl' addFirstPartyCaveat m0- where+ where m0 = Macaroon loc mid [] $ createSignature (deriveKey k) mid - -- | A first party caveat corresponds to a proposition that might or might not -- hold in the validation context of the macaroon. addFirstPartyCaveat :: Macaroon -> ByteString -> Macaroon addFirstPartyCaveat m = addCaveat m . Caveat mempty Nothing - -- | A third party caveat links the macaroon to an additional key, and must be -- discharged by a supplementary macaroon in order to validate.-addThirdPartyCaveat- :: Macaroon- -> Key- -- ^ third party key- -> Location- -> ByteString- -> IO Macaroon-addThirdPartyCaveat m ck loc c- = addC <$> encryptKey (macaroonSignature m) (deriveKey ck)- where+addThirdPartyCaveat ::+ Macaroon ->+ -- | third party key+ Key ->+ Location ->+ ByteString ->+ IO Macaroon+addThirdPartyCaveat m ck loc c =+ addC <$> encryptKey (macaroonSignature m) (deriveKey ck)+ where addC k = addCaveat m $ Caveat loc (Just k) c - addCaveat :: Macaroon -> Caveat -> Macaroon-addCaveat m c@Caveat{ caveatKeyId = k, caveatContent = cc }- = m { caveats = caveats m <> [c]+addCaveat m c@Caveat{caveatKeyId = k, caveatContent = cc} =+ m+ { caveats = caveats m <> [c] , macaroonSignature = updateSignature (macaroonSignature m) k cc } - -- | Get the third party caveats encoded in the macaroon extractThirdPartyCaveats :: Macaroon -> [ByteString] extractThirdPartyCaveats = fmap caveatContent . filter isThirdParty . caveats - isThirdParty :: Caveat -> Bool isThirdParty = isJust . caveatKeyId - -- | Mint a macaroon discharging a third party caveat-createDischargeMacaroon- :: Key- -- ^ discharge key- -> Location- -- ^ location hint- -> ByteString- -- ^ caveat to discharge- -> [ByteString]- -- ^ additional first party caveats to include- -> Macaroon+createDischargeMacaroon ::+ -- | discharge key+ Key ->+ -- | location hint+ Location ->+ -- | caveat to discharge+ ByteString ->+ -- | additional first party caveats to include+ [ByteString] ->+ Macaroon createDischargeMacaroon k l c = createMacaroon k (MacaroonId c) l - -- | In order to secure discharge macaroons, they must be bound to the root macaroon before transmission.-sealMacaroon- :: Macaroon- -- ^ root macaroon- -> [Macaroon]- -- ^ discharge macaroons- -> SealedMacaroon-sealMacaroon m@Macaroon{ macaroonSignature = s } ms- = SealedMacaroon m $ bindMacaroon <$> ms- where- bindMacaroon m'@Macaroon{ macaroonSignature = s' }- = m' { macaroonSignature = bindForRequest s s' }+sealMacaroon ::+ -- | root macaroon+ Macaroon ->+ -- | discharge macaroons+ [Macaroon] ->+ SealedMacaroon+sealMacaroon m@Macaroon{macaroonSignature = s} ms =+ SealedMacaroon m $ bindMacaroon <$> ms+ where+ bindMacaroon m'@Macaroon{macaroonSignature = s'} =+ m'{macaroonSignature = bindForRequest s s'}
src/Authorize/Macaroon/Crypto.hs view
@@ -1,86 +1,90 @@ {-# LANGUAGE OverloadedStrings #-} -module Authorize.Macaroon.Crypto- ( createSignature- , updateSignature- , encryptKey- , decryptKey- , bindForRequest- , deriveKey- ) where--import Crypto.Hash (SHA256)-import Crypto.MAC.HMAC (HMAC, hmac)-import qualified Crypto.Saltine.Class as Nacl-import Crypto.Saltine.Core.SecretBox (newNonce, secretbox,- secretboxOpen)-import qualified Crypto.Saltine.Internal.ByteSizes as Sizes-import Data.ByteArray (ByteArray, ByteArrayAccess,- convert)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS--import Authorize.Macaroon.Types (Key (..), KeyId (..),- MacaroonId (..),- Signature (..))+module Authorize.Macaroon.Crypto (+ createSignature,+ updateSignature,+ encryptKey,+ decryptKey,+ bindForRequest,+ deriveKey,+) where +import Authorize.Macaroon.Types (+ Key (..),+ KeyId (..),+ MacaroonId (..),+ Signature (..),+ )+import Crypto.Hash (SHA256)+import Crypto.MAC.HMAC (HMAC, hmac)+import Crypto.Saltine.Class qualified as Nacl+import Crypto.Saltine.Core.SecretBox (+ newNonce,+ secretbox,+ secretboxOpen,+ )+import Crypto.Saltine.Internal.SecretBox (secretbox_noncebytes)+import Data.ByteArray (+ ByteArray,+ ByteArrayAccess,+ convert,+ )+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS createSignature :: Key -> MacaroonId -> Signature createSignature k m = Signature $ keyedHash k m - updateSignature :: Signature -> Maybe KeyId -> ByteString -> Signature updateSignature s kid c = Signature $ maybe (keyedHash s) (keyedPairHash s) kid c - encryptKey :: Signature -> Key -> IO KeyId encryptKey (Signature s) (Key k) = do- n <- newNonce+ n <- newNonce key <- maybe err return $ Nacl.decode s return . KeyId $ Nacl.encode n <> secretbox key n (convert k)- where+ where err = error "Unable to decode key" - decryptKey :: Signature -> KeyId -> Maybe Key decryptKey (Signature s) (KeyId kid) = do- n <- Nacl.decode nonceBytes+ n <- Nacl.decode nonceBytes key <- Nacl.decode s Key . convert <$> secretboxOpen key n ct- where- (nonceBytes, ct) = BS.splitAt Sizes.secretBoxNonce kid-+ where+ (nonceBytes, ct) = BS.splitAt secretbox_noncebytes kid bindForRequest :: Signature -> Signature -> Signature bindForRequest = keyedPairHash zeroKey- where+ where zeroKey = BS.replicate 32 0x0 - hmac256 :: (ByteArrayAccess k, ByteArrayAccess x) => k -> x -> HMAC SHA256 hmac256 = hmac - deriveKey :: Key -> Key deriveKey (Key k) = Key . convert $ hmac256 tag k- where+ where tag :: ByteString tag = "macaroons-key-generator" --keyedHash- :: (ByteArrayAccess k, ByteArrayAccess b, ByteArray c)- => k -> b -> c+keyedHash ::+ (ByteArrayAccess k, ByteArrayAccess b, ByteArray c) =>+ k ->+ b ->+ c keyedHash k = convert . hmac256 k --keyedPairHash- :: ( ByteArrayAccess k- , ByteArrayAccess b- , ByteArrayAccess c- , ByteArray d- , Monoid d- )- => k -> b -> c -> d-keyedPairHash k x y- = keyedHash k (keyedHash k x <> keyedHash k y :: ByteString)+keyedPairHash ::+ ( ByteArrayAccess k+ , ByteArrayAccess b+ , ByteArrayAccess c+ , ByteArray d+ , Monoid d+ ) =>+ k ->+ b ->+ c ->+ d+keyedPairHash k x y =+ keyedHash k (keyedHash k x <> keyedHash k y :: ByteString)
src/Authorize/Macaroon/Serialize.hs view
@@ -1,50 +1,42 @@-module Authorize.Macaroon.Serialize- ( fieldEOS- , fieldLocation- , fieldIdentifier- , fieldVerificationId- , fieldSignature-- , putField- , getField- , getOptionalField- , getEOS- , atEOS- ) where--import qualified Data.Bytes.Serial as By-import Data.Bytes.VarInt (VarInt (..))-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.Serialize (Get, Put, Serialize (..))-import qualified Data.Serialize as S-import Data.Word (Word8)+module Authorize.Macaroon.Serialize (+ fieldEOS,+ fieldLocation,+ fieldIdentifier,+ fieldVerificationId,+ fieldSignature,+ putField,+ getField,+ getOptionalField,+ getEOS,+ atEOS,+) where +import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Bytes.Serial qualified as By+import Data.Bytes.VarInt (VarInt (..))+import Data.Serialize (Get, Put, Serialize (..))+import Data.Serialize qualified as S+import Data.Word (Word8) fieldEOS :: Word8 fieldEOS = 0 - fieldLocation :: Word8 fieldLocation = 1 - fieldIdentifier :: Word8 fieldIdentifier = 2 - fieldVerificationId :: Word8 fieldVerificationId = 4 - fieldSignature :: Word8 fieldSignature = 6 - putField :: Word8 -> ByteString -> Put-putField fieldId dat- = put fieldId >> By.serialize (VarInt $ BS.length dat) >> S.putByteString dat-+putField fieldId dat =+ put fieldId >> By.serialize (VarInt $ BS.length dat) >> S.putByteString dat getOptionalField :: Word8 -> Get (Maybe ByteString) getOptionalField f = do@@ -53,24 +45,20 @@ then S.getWord8 >> Just <$> getFieldData else return Nothing - getField :: Word8 -> Get ByteString getField f = do n <- S.getWord8 if n == f then getFieldData else fail $ "Expecting field " <> show f <> " but got " <> show n - getFieldData :: Get ByteString getFieldData = do VarInt n <- By.deserialize S.getBytes n - getEOS :: Get () getEOS = do f <- S.getWord8 if f == fieldEOS then return () else fail "Expecting EOS"- atEOS :: Get Bool atEOS = (== fieldEOS) <$> S.lookAhead S.getWord8
src/Authorize/Macaroon/Types.hs view
@@ -1,139 +1,130 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}--module Authorize.Macaroon.Types- ( MacaroonId (..)- , Macaroon (..)- , Caveat (..)-- , SealedMacaroon (..)-- , Key (..)- , KeyId (..)- , Signature (..)- , Location- ) where--import Control.Monad (unless)-import Data.ByteArray (ByteArray, ByteArrayAccess,- ScrubbedBytes)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.Maybe (fromMaybe)-import Data.Serialize (Serialize (..))-import qualified Data.Serialize as S+{-# LANGUAGE OverloadedStrings #-} -import Authorize.Macaroon.Serialize+module Authorize.Macaroon.Types (+ MacaroonId (..),+ Macaroon (..),+ Caveat (..),+ SealedMacaroon (..),+ Key (..),+ KeyId (..),+ Signature (..),+ Location,+) where +import Authorize.Macaroon.Serialize qualified as MS+import Control.Monad (unless)+import Data.ByteArray (+ ByteArray,+ ByteArrayAccess,+ ScrubbedBytes,+ )+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Maybe (fromMaybe)+import Data.Serialize (Serialize (..))+import Data.Serialize qualified as S type Location = ByteString --newtype MacaroonId = MacaroonId { unMacaroonId :: ByteString }+newtype MacaroonId = MacaroonId {unMacaroonId :: ByteString} deriving (Eq, Ord, Show, ByteArrayAccess, Serialize) --newtype Key = Key { unKey :: ScrubbedBytes } deriving (Eq, Ord, Show, ByteArrayAccess)---newtype KeyId = KeyId { unKeyId :: ByteString } deriving (Eq, Ord, Show, ByteArrayAccess)-+newtype Key = Key {unKey :: ScrubbedBytes} deriving (Eq, Ord, Show, ByteArrayAccess) -newtype Signature = Signature { unSignature :: ByteString }- deriving ( Eq- , Ord- , Semigroup- , Monoid- , ByteArray- , ByteArrayAccess- , Serialize- , Show- )+newtype KeyId = KeyId {unKeyId :: ByteString} deriving (Eq, Ord, Show, ByteArrayAccess) +newtype Signature = Signature {unSignature :: ByteString}+ deriving+ ( Eq+ , Ord+ , Semigroup+ , Monoid+ , ByteArray+ , ByteArrayAccess+ , Serialize+ , Show+ ) data Macaroon = Macaroon- { locationHint :: Location- , identifier :: MacaroonId- , caveats :: [Caveat]+ { locationHint :: Location+ , identifier :: MacaroonId+ , caveats :: [Caveat] , macaroonSignature :: Signature- } deriving (Eq, Show)-+ }+ deriving (Eq, Show) instance Serialize Macaroon where put (Macaroon loc i cs sig) = do S.putWord8 2 -- version byte-- unless (BS.null loc) $ putField fieldLocation loc- putField fieldIdentifier $ unMacaroonId i- put fieldEOS+ unless (BS.null loc) $ MS.putField MS.fieldLocation loc+ MS.putField MS.fieldIdentifier $ unMacaroonId i+ put MS.fieldEOS mapM_ put cs- put fieldEOS+ put MS.fieldEOS - putField fieldSignature $ unSignature sig+ MS.putField MS.fieldSignature $ unSignature sig get = do getVersion - mloc <- getOptionalField fieldLocation- mid <- MacaroonId <$> getField fieldIdentifier- getEOS+ mloc <- MS.getOptionalField MS.fieldLocation+ mid <- MacaroonId <$> MS.getField MS.fieldIdentifier+ MS.getEOS cs <- getCaveats- getEOS+ MS.getEOS - sig <- Signature <$> getField fieldSignature+ sig <- Signature <$> MS.getField MS.fieldSignature return $ Macaroon (fromMaybe mempty mloc) mid cs sig-- where+ where getVersion = do v <- S.getWord8 if v == 2 then return () else fail "Unsupported macaroon version" getCaveats = do- eos <- atEOS+ eos <- MS.atEOS if eos then return [] else (:) <$> get <*> getCaveats - data Caveat = Caveat { caveatLocationHint :: Location -- ^ Note: The location hint is not authenticated- , caveatKeyId :: Maybe KeyId+ , caveatKeyId :: Maybe KeyId -- ^ First party caveats do not require a key ident- , caveatContent :: ByteString+ , caveatContent :: ByteString -- ^ content semantics are determined in the application layer- } deriving (Eq, Show)-+ }+ deriving (Eq, Show) instance Serialize Caveat where put (Caveat loc mk c) = do- unless (BS.null loc) $ putField fieldLocation loc- putField fieldIdentifier c- mapM_ (putField fieldVerificationId . unKeyId) mk- put fieldEOS+ unless (BS.null loc) $ MS.putField MS.fieldLocation loc+ MS.putField MS.fieldIdentifier c+ mapM_ (MS.putField MS.fieldVerificationId . unKeyId) mk+ put MS.fieldEOS - get = makeCaveat- <$> getOptionalField fieldLocation- <*> getField fieldIdentifier- <*> getOptionalField fieldVerificationId- <* getEOS- where+ get =+ makeCaveat+ <$> MS.getOptionalField MS.fieldLocation+ <*> MS.getField MS.fieldIdentifier+ <*> MS.getOptionalField MS.fieldVerificationId+ <* MS.getEOS+ where makeCaveat mloc c mkeyid = Caveat (fromMaybe mempty mloc) (KeyId <$> mkeyid) c - -- | Couple a macaroon with its discharges. Application developers should -- only produce these values either by invoking @prepareForRequest@ or by -- deserializing a client token. data SealedMacaroon = SealedMacaroon- { rootMacaroon :: Macaroon+ { rootMacaroon :: Macaroon , dischargeMacaroons :: [Macaroon]- } deriving (Eq, Show)-+ }+ deriving (Eq, Show) instance Serialize SealedMacaroon where put (SealedMacaroon r ds) = put r >> mapM_ put ds get = SealedMacaroon <$> get <*> getMacaroons- where+ where getMacaroons = do n <- S.remaining if n > 0 then (:) <$> get <*> getMacaroons else return []
src/Authorize/Macaroon/Verify.hs view
@@ -1,22 +1,34 @@-module Authorize.Macaroon.Verify- ( VerificationFailure (..)- , verify- , recalcSignature- ) where--import Control.Arrow ((&&&))-import Control.Monad (foldM, unless)-import Data.ByteArray (constEq)-import Data.ByteString (ByteString)-import Data.Foldable (foldl')-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Set (Set)-import qualified Data.Set as Set--import Authorize.Macaroon.Crypto-import Authorize.Macaroon.Types+module Authorize.Macaroon.Verify (+ VerificationFailure (..),+ verify,+ recalcSignature,+) where +import Authorize.Macaroon.Crypto (+ bindForRequest,+ createSignature,+ decryptKey,+ deriveKey,+ updateSignature,+ )+import Authorize.Macaroon.Types (+ Caveat (Caveat),+ Key,+ KeyId,+ Macaroon (..),+ MacaroonId (MacaroonId),+ SealedMacaroon (SealedMacaroon),+ Signature,+ )+import Control.Arrow ((&&&))+import Control.Monad (foldM, unless)+import Data.ByteArray (constEq)+import Data.ByteString (ByteString)+import Data.Foldable (foldl')+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set data VerificationFailure = InvalidSignature MacaroonId@@ -26,89 +38,83 @@ | ThirdPartyKeyError MacaroonId deriving (Eq, Show) - type Discharges = Map MacaroonId Macaroon - -- | Macaroon verification succeeds by producing a set of first party caveats -- requiring further validation.-verify- :: Key- -- ^ root key- -> SealedMacaroon- -> Either VerificationFailure (Set ByteString)+verify ::+ -- | root key+ Key ->+ SealedMacaroon ->+ Either VerificationFailure (Set ByteString) verify rootKey (SealedMacaroon m ms) = do (cs, ds') <- verify' (deriveKey rootKey) m ds unless (Map.null ds') $ Left (ExcessDischarges $ Map.elems ds') return cs-- where+ where ds = Map.fromList $ (identifier &&& id) <$> ms --verify'- :: Key- -> Macaroon- -> Discharges- -> Either VerificationFailure (Set ByteString, Discharges)+verify' ::+ Key ->+ Macaroon ->+ Discharges ->+ Either VerificationFailure (Set ByteString, Discharges) verify' k m ds = checkSig =<< foldM step (sig0, mempty, ds) (caveats m)- where- step (sig, cs, ds') (Caveat _ mk c)- = updateSig mk c sig <$> maybe firstP (verThirdP sig) mk c cs ds'+ where+ step (sig, cs, ds') (Caveat _ mk c) =+ updateSig mk c sig <$> maybe firstP (verThirdP sig) mk c cs ds' firstP c cs ds' = return (Set.singleton c <> cs, ds')- verThirdP = verifyThirdParty (macaroonSignature m)+ verThirdP = verifyThirdParty (macaroonSignature m) - sig0 = createSignature k (identifier m)+ sig0 = createSignature k (identifier m) updateSig mk c sig (x, y) = (updateSignature sig mk c, x, y) - checkSig (sig, cs', ds')- = (cs', ds') <$ unless (sig `constEq` macaroonSignature m)- (Left . InvalidSignature $ identifier m)-+ checkSig (sig, cs', ds') =+ (cs', ds')+ <$ unless+ (sig `constEq` macaroonSignature m)+ (Left . InvalidSignature $ identifier m) -verifyThirdParty- :: Signature- -- ^ root signature- -> Signature- -- ^ running signature- -> KeyId- -> ByteString- -> Set ByteString- -> Discharges- -> Either VerificationFailure (Set ByteString, Discharges)+verifyThirdParty ::+ -- | root signature+ Signature ->+ -- | running signature+ Signature ->+ KeyId ->+ ByteString ->+ Set ByteString ->+ Discharges ->+ Either VerificationFailure (Set ByteString, Discharges) verifyThirdParty rootSig runningSig k c acc ds = do (m, ds') <- getDischarge (MacaroonId c) ds- k' <- getKey (identifier m) runningSig k+ k' <- getKey (identifier m) runningSig k - let unboundSig = recalcSignature k' (identifier m) (caveats m)- dischargeSig = macaroonSignature m- unboundDischarge = m {macaroonSignature = unboundSig}+ let unboundSig = recalcSignature k' (identifier m) (caveats m)+ dischargeSig = macaroonSignature m+ unboundDischarge = m{macaroonSignature = unboundSig} - unless (bindForRequest rootSig unboundSig == dischargeSig)- $ Left (InvalidBinding $ identifier m)+ unless (bindForRequest rootSig unboundSig == dischargeSig) $+ Left (InvalidBinding $ identifier m) (acc', ds'') <- verify' k' unboundDischarge ds' return (acc' <> acc, ds'') --getDischarge- :: MacaroonId- -> Discharges- -> Either VerificationFailure (Macaroon, Discharges)+getDischarge ::+ MacaroonId ->+ Discharges ->+ Either VerificationFailure (Macaroon, Discharges) getDischarge mid ds = maybe noDischarge someDischarge $ Map.lookup mid ds- where+ where someDischarge m = return (m, Map.delete mid ds)- noDischarge = Left $ MissingDischargeMacaroon mid-+ noDischarge = Left $ MissingDischargeMacaroon mid getKey :: MacaroonId -> Signature -> KeyId -> Either VerificationFailure Key getKey mid sig = maybe noKey return . decryptKey sig- where+ where noKey = Left $ ThirdPartyKeyError mid - recalcSignature :: Key -> MacaroonId -> [Caveat] -> Signature recalcSignature k i = foldl' step (createSignature k i)- where+ where step sig (Caveat _ mk c) = updateSignature sig mk c
test/Authorize/Macaroon/Gen.hs view
@@ -1,74 +1,57 @@-module Authorize.Macaroon.Gen- ( sealedMacaroon- , macaroon- , location- , caveat- , content- , key- , signature- , validMacaroon- ) where--import Data.ByteArray (convert)-import Data.ByteString (ByteString)-import Data.Set (Set)-import qualified Data.Set as Set-import Hedgehog (Gen)-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range--import Authorize.Macaroon-import Authorize.Macaroon.Types (Caveat (..), KeyId (..),- Macaroon (..), Signature (..))---sealedMacaroon :: Gen SealedMacaroon-sealedMacaroon = SealedMacaroon <$> macaroon <*> macaroons- where- macaroons = Gen.list (Range.constant 0 100) macaroon---macaroon :: Gen Macaroon-macaroon = Macaroon <$> location <*> genIdentifier <*> genCaveats <*> signature- where- genCaveats = Gen.list (Range.constant 0 100) caveat-+module Authorize.Macaroon.Gen (+ location,+ content,+ key,+ validMacaroon,+ macaroon,+ sealedMacaroon,+) where -caveat :: Gen Caveat-caveat = Caveat <$> location <*> gKeyId <*> content- where- gKeyId = Gen.choice [pure Nothing, Just <$> keyId]+import Data.ByteArray (convert)+import Data.ByteString (ByteString)+import Data.Set (Set)+import Data.Set qualified as Set+import Hedgehog (Gen)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range +import Authorize.Macaroon (+ Key (..),+ Location,+ Macaroon,+ MacaroonId (..),+ SealedMacaroon,+ createMacaroon,+ sealMacaroon,+ ) content :: Gen ByteString content = Gen.bytes $ Range.constant 1 128 --keyId :: Gen KeyId-keyId = KeyId <$> Gen.bytes (Range.singleton 32)-- location :: Gen Location location = Gen.bytes $ Range.constant 0 64 - genIdentifier :: Gen MacaroonId genIdentifier = MacaroonId <$> Gen.bytes (Range.constant 1 256) --signature :: Gen Signature-signature = Signature <$> Gen.bytes (Range.singleton 32)+sealedMacaroon :: Gen SealedMacaroon+sealedMacaroon = sealMacaroon <$> macaroon <*> macaroons+ where+ macaroons = Gen.list (Range.constant 1 10) macaroon +macaroon :: Gen Macaroon+macaroon = pr2 <$> validMacaroon+ where+ pr2 (_, x, _) = x validMacaroon :: Gen (Key, Macaroon, Set ByteString) validMacaroon = do- k <- key- i <- genIdentifier- cs <- Gen.list (Range.constant 1 10) content+ k <- key+ i <- genIdentifier+ cs <- Gen.list (Range.constant 1 10) content loc <- location let m = createMacaroon k i loc cs return (k, m, Set.fromList cs)- key :: Gen Key key = Key . convert <$> Gen.bytes (Range.singleton 32)
test/Main.hs view
@@ -1,142 +1,128 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}--module Main where--import Control.Monad (foldM)-import Control.Monad.IO.Class (liftIO)-import Data.Serialize (Serialize)-import qualified Data.Serialize as S-import qualified Data.Set as Set-import Hedgehog (Gen, Group (..), Property,- PropertyT, TestLimit, assert,- checkParallel, diff, forAll,- property, withTests, (===))-import Hedgehog.Main (defaultMain)-import qualified Hedgehog.Range as Range+{-# LANGUAGE TupleSections #-} -import Authorize.Macaroon (Macaroon, SealedMacaroon (..),- VerificationFailure (..),- addThirdPartyCaveat,- createDischargeMacaroon,- sealMacaroon, verify)-import Authorize.Macaroon.Crypto (decryptKey, encryptKey)-import qualified Authorize.Macaroon.Gen as G-import qualified Hedgehog.Gen as Gen+module Main (main) where +import Authorize.Macaroon (+ Macaroon,+ SealedMacaroon (..),+ VerificationFailure (..),+ addThirdPartyCaveat,+ createDischargeMacaroon,+ sealMacaroon,+ verify,+ )+import Authorize.Macaroon.Gen qualified as G+import Control.Monad (foldM)+import Control.Monad.IO.Class (liftIO)+import Data.Serialize (Serialize)+import Data.Serialize qualified as S+import Data.Set qualified as Set+import Hedgehog (+ Gen,+ Group (..),+ Property,+ PropertyT,+ TestLimit,+ assert,+ checkParallel,+ diff,+ forAll,+ property,+ withTests,+ (===),+ )+import Hedgehog.Gen qualified as Gen+import Hedgehog.Main (defaultMain)+import Hedgehog.Range qualified as Range main :: IO ()-main = defaultMain [ checkParallel testSerialization- , checkParallel testCrypto- , checkParallel testVerification- ]-+main =+ defaultMain+ [ checkParallel testSerialization+ , checkParallel testVerification+ ] testSerialization :: Group-testSerialization = Group "Serialization"- [ ("Caveat" , testCaveatSerialization)- , ("Macaroon" , testMacaroonSerialization)- , ("SealedMacaroon" , testSealedMacaroonSerialization)- ]---testCaveatSerialization :: Property-testCaveatSerialization = roundTripProperty 1000 G.caveat-+testSerialization =+ Group+ "Serialization"+ [ ("Macaroon", testMacaroonSerialization)+ , ("SealedMacaroon", testSealedMacaroonSerialization)+ ] testMacaroonSerialization :: Property testMacaroonSerialization = roundTripProperty 500 G.macaroon - testSealedMacaroonSerialization :: Property testSealedMacaroonSerialization = roundTripProperty 20 G.sealedMacaroon - roundTripProperty :: (Eq a, Show a, Serialize a) => TestLimit -> Gen a -> Property roundTripProperty n g = withTests n . property $ do x <- forAll g diff (roundTrip x) (==) (Right x) - roundTrip :: Serialize a => a -> Either String a roundTrip = S.decode . S.encode --testCrypto :: Group-testCrypto = Group "Cryptography"- [ ("Key encryption", testKeyEncryption) ]---testKeyEncryption :: Property-testKeyEncryption = withTests 10 . property $ do- x <- forAll G.key- s <- forAll G.signature- ct <- liftIO $ encryptKey s x- decryptKey s ct === Just x-- testVerification :: Group-testVerification = Group "Verification"- [ ("Passes (simple)" , testPasses)- , ("Passes (complex)" , testComplexPasses)- , ("Fails (missing discharge)" , testMissingDischarge)- , ("Fails (invalid key)" , testInvalidKey)- , ("Fails (invalid binding)" , testInvalidBinding)- ]-+testVerification =+ Group+ "Verification"+ [ ("Passes (simple)", testPasses)+ , ("Passes (complex)", testComplexPasses)+ , ("Fails (missing discharge)", testMissingDischarge)+ , ("Fails (invalid key)", testInvalidKey)+ , ("Fails (invalid binding)", testInvalidBinding)+ ] testPasses :: Property testPasses = withTests 100 . property $ do (k, m, cs) <- forAll G.validMacaroon verify k (SealedMacaroon m []) === Right cs - testComplexPasses :: Property testComplexPasses = withTests 100 . property $ do (k, m, cs) <- forAll G.validMacaroon- sm <- uncurry sealMacaroon <$> addThirdPartyCaveats m+ sm <- uncurry sealMacaroon <$> addThirdPartyCaveats m verify k sm === Right cs - addThirdPartyCaveats :: Macaroon -> PropertyT IO (Macaroon, [Macaroon])-addThirdPartyCaveats m0- = forAll genThirdPartyCaveats >>= foldM step (m0, [])- where- genThirdPartyCaveats- = Gen.set (Range.constant 1 10) G.content >>= traverse inflateTPData . Set.toList- inflateTPData c = (, , c) <$> G.key <*> G.location+addThirdPartyCaveats m0 =+ forAll genThirdPartyCaveats >>= foldM step (m0, [])+ where+ genThirdPartyCaveats =+ Gen.set (Range.constant 1 10) G.content >>= traverse inflateTPData . Set.toList+ inflateTPData c = (,,c) <$> G.key <*> G.location step (m, ds) (ck, l, c) = do m' <- liftIO $ addThirdPartyCaveat m ck l c let d = createDischargeMacaroon ck l c [] return (m', ds <> [d]) - testMissingDischarge :: Property testMissingDischarge = withTests 100 . property $ do (k, m, _) <- forAll G.validMacaroon- (m', _) <- addThirdPartyCaveats m+ (m', _) <- addThirdPartyCaveats m assert . isMissingDischarge $ verify k (SealedMacaroon m' [])- where+ where isMissingDischarge (Left (MissingDischargeMacaroon _)) = True- isMissingDischarge _ = False-+ isMissingDischarge _ = False testInvalidKey :: Property testInvalidKey = withTests 100 . property $ do- k <- forAll G.key+ k <- forAll G.key (_, m, _) <- forAll G.validMacaroon assert . isInvalidSignature $ verify k (SealedMacaroon m [])- where+ where isInvalidSignature (Left (InvalidSignature _)) = True- isInvalidSignature _ = False-+ isInvalidSignature _ = False testInvalidBinding :: Property testInvalidBinding = withTests 100 . property $ do (k, m, _) <- forAll G.validMacaroon- sm <- uncurry SealedMacaroon <$> addThirdPartyCaveats m+ sm <- uncurry SealedMacaroon <$> addThirdPartyCaveats m assert . isInvalidBinding $ verify k sm- where+ where isInvalidBinding (Left (InvalidBinding _)) = True- isInvalidBinding _ = False+ isInvalidBinding _ = False