diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/macaroon-shop.cabal b/macaroon-shop.cabal --- a/macaroon-shop.cabal +++ b/macaroon-shop.cabal @@ -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 diff --git a/src/Authorize/Macaroon.hs b/src/Authorize/Macaroon.hs --- a/src/Authorize/Macaroon.hs +++ b/src/Authorize/Macaroon.hs @@ -8,116 +8,118 @@ -- . The -- serialization, cryptography, and validation semantics are compatible with -- go-macaroons . -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'} diff --git a/src/Authorize/Macaroon/Crypto.hs b/src/Authorize/Macaroon/Crypto.hs --- a/src/Authorize/Macaroon/Crypto.hs +++ b/src/Authorize/Macaroon/Crypto.hs @@ -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) diff --git a/src/Authorize/Macaroon/Serialize.hs b/src/Authorize/Macaroon/Serialize.hs --- a/src/Authorize/Macaroon/Serialize.hs +++ b/src/Authorize/Macaroon/Serialize.hs @@ -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 diff --git a/src/Authorize/Macaroon/Types.hs b/src/Authorize/Macaroon/Types.hs --- a/src/Authorize/Macaroon/Types.hs +++ b/src/Authorize/Macaroon/Types.hs @@ -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 [] diff --git a/src/Authorize/Macaroon/Verify.hs b/src/Authorize/Macaroon/Verify.hs --- a/src/Authorize/Macaroon/Verify.hs +++ b/src/Authorize/Macaroon/Verify.hs @@ -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 diff --git a/test/Authorize/Macaroon/Gen.hs b/test/Authorize/Macaroon/Gen.hs --- a/test/Authorize/Macaroon/Gen.hs +++ b/test/Authorize/Macaroon/Gen.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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