-- |
-- Module:      Authorize.Macaroon
-- License:     ISC
-- Maintainer:  ics@gambolingpangolin.com
-- Stability:   experimental
--
-- This module contains an implementation of macaroons as described in
-- <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 (
    -- * Types
    MacaroonId (..),
    Macaroon,
    SealedMacaroon (..),
    Key (..),
    Location,

    -- * Core interface
    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 ::
    -- | signing key
    Key ->
    -- | identifier for this macaroon
    MacaroonId ->
    -- | location hint
    Location ->
    -- | first party caveats to include
    [ByteString] ->
    Macaroon
createMacaroon :: Key -> MacaroonId -> Location -> [Location] -> Macaroon
createMacaroon Key
k MacaroonId
mid Location
loc = (Macaroon -> Location -> Macaroon)
-> Macaroon -> [Location] -> Macaroon
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Macaroon -> Location -> Macaroon
addFirstPartyCaveat Macaroon
m0
  where
    m0 :: Macaroon
m0 = Location -> MacaroonId -> [Caveat] -> Signature -> Macaroon
Macaroon Location
loc MacaroonId
mid [] (Signature -> Macaroon) -> Signature -> Macaroon
forall a b. (a -> b) -> a -> b
$ Key -> MacaroonId -> Signature
createSignature (Key -> Key
deriveKey Key
k) MacaroonId
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 :: Macaroon -> Location -> Macaroon
addFirstPartyCaveat Macaroon
m = Macaroon -> Caveat -> Macaroon
addCaveat Macaroon
m (Caveat -> Macaroon)
-> (Location -> Caveat) -> Location -> Macaroon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Maybe KeyId -> Location -> Caveat
Caveat Location
forall a. Monoid a => a
mempty Maybe KeyId
forall a. Maybe a
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 ->
    -- | third party key
    Key ->
    Location ->
    ByteString ->
    IO Macaroon
addThirdPartyCaveat :: Macaroon -> Key -> Location -> Location -> IO Macaroon
addThirdPartyCaveat Macaroon
m Key
ck Location
loc Location
c =
    KeyId -> Macaroon
addC (KeyId -> Macaroon) -> IO KeyId -> IO Macaroon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signature -> Key -> IO KeyId
encryptKey (Macaroon -> Signature
macaroonSignature Macaroon
m) (Key -> Key
deriveKey Key
ck)
  where
    addC :: KeyId -> Macaroon
addC KeyId
k = Macaroon -> Caveat -> Macaroon
addCaveat Macaroon
m (Caveat -> Macaroon) -> Caveat -> Macaroon
forall a b. (a -> b) -> a -> b
$ Location -> Maybe KeyId -> Location -> Caveat
Caveat Location
loc (KeyId -> Maybe KeyId
forall a. a -> Maybe a
Just KeyId
k) Location
c

addCaveat :: Macaroon -> Caveat -> Macaroon
addCaveat :: Macaroon -> Caveat -> Macaroon
addCaveat Macaroon
m c :: Caveat
c@Caveat{caveatKeyId :: Caveat -> Maybe KeyId
caveatKeyId = Maybe KeyId
k, caveatContent :: Caveat -> Location
caveatContent = Location
cc} =
    Macaroon
m
        { caveats = caveats m <> [c]
        , macaroonSignature = updateSignature (macaroonSignature m) k cc
        }

-- | Get the third party caveats encoded in the macaroon
extractThirdPartyCaveats :: Macaroon -> [ByteString]
extractThirdPartyCaveats :: Macaroon -> [Location]
extractThirdPartyCaveats = (Caveat -> Location) -> [Caveat] -> [Location]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Caveat -> Location
caveatContent ([Caveat] -> [Location])
-> (Macaroon -> [Caveat]) -> Macaroon -> [Location]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Caveat -> Bool) -> [Caveat] -> [Caveat]
forall a. (a -> Bool) -> [a] -> [a]
filter Caveat -> Bool
isThirdParty ([Caveat] -> [Caveat])
-> (Macaroon -> [Caveat]) -> Macaroon -> [Caveat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Macaroon -> [Caveat]
caveats

isThirdParty :: Caveat -> Bool
isThirdParty :: Caveat -> Bool
isThirdParty = Maybe KeyId -> Bool
forall a. Maybe a -> Bool
isJust (Maybe KeyId -> Bool) -> (Caveat -> Maybe KeyId) -> Caveat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Caveat -> Maybe KeyId
caveatKeyId

-- | Mint a macaroon discharging a third party caveat
createDischargeMacaroon ::
    -- | discharge key
    Key ->
    -- | location hint
    Location ->
    -- | caveat to discharge
    ByteString ->
    -- | additional first party caveats to include
    [ByteString] ->
    Macaroon
createDischargeMacaroon :: Key -> Location -> Location -> [Location] -> Macaroon
createDischargeMacaroon Key
k Location
l Location
c = Key -> MacaroonId -> Location -> [Location] -> Macaroon
createMacaroon Key
k (Location -> MacaroonId
MacaroonId Location
c) Location
l

-- | In order to secure discharge macaroons, they must be bound to the root macaroon before transmission.
sealMacaroon ::
    -- | root macaroon
    Macaroon ->
    -- | discharge macaroons
    [Macaroon] ->
    SealedMacaroon
sealMacaroon :: Macaroon -> [Macaroon] -> SealedMacaroon
sealMacaroon m :: Macaroon
m@Macaroon{macaroonSignature :: Macaroon -> Signature
macaroonSignature = Signature
s} [Macaroon]
ms =
    Macaroon -> [Macaroon] -> SealedMacaroon
SealedMacaroon Macaroon
m ([Macaroon] -> SealedMacaroon) -> [Macaroon] -> SealedMacaroon
forall a b. (a -> b) -> a -> b
$ Macaroon -> Macaroon
bindMacaroon (Macaroon -> Macaroon) -> [Macaroon] -> [Macaroon]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Macaroon]
ms
  where
    bindMacaroon :: Macaroon -> Macaroon
bindMacaroon m' :: Macaroon
m'@Macaroon{macaroonSignature :: Macaroon -> Signature
macaroonSignature = Signature
s'} =
        Macaroon
m'{macaroonSignature = bindForRequest s s'}