{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-|
  Module      : Network.Wai.Middleware.Biscuit
  Copyright   : © Clément Delafargue, 2025
  License     : BSD-3-Clause
  Maintainer  : clement@delafargue.name
  WAI support for biscuit tokens

  This module provides WAI middlewares as well as builder functions for WAI middlewares, that allow protecting an HTTP application with biscuit tokens.

  The middlewares use the request vault to store either a verified biscuit token (see 'parseBiscuit', 'parseOptionalBiscuit', and 'parseBiscuitWith'),
  letting the application perform authorization, or the result of the authorization for cases where authorization is the same for all requests and can be performed directly in the middleware (see 'authorizeBiscuit'' and 'authorizeBiscuitWith')
-}
module Network.Wai.Middleware.Biscuit
  (
  -- * Biscuit parsing
    parseBiscuit
  , parseOptionalBiscuit
  , getBiscuit
  , parseBiscuitWith
  , ExtractionConfig (..)
  , defaultExtractionConfig
  , defaultOptionalExtractionConfig
  -- * Biscuit authorization
  , authorizeBiscuit'
  , getAuthorizedBiscuit
  , authorizeBiscuitWith
  , AuthorizationConfig (..)
  , defaultAuthorizationConfig
  -- * Helpers
  , defaultExtractToken
  , defaultHandleError
  , BiscuitError (..)
  ) where

import           Auth.Biscuit       (AuthorizedBiscuit, Authorizer, Biscuit,
                                     ExecutionError, OpenOrSealed, ParseError,
                                     PublicKey, Verified, authorizeBiscuit,
                                     parseB64)
import           Control.Monad      ((<=<))
import           Data.Bifunctor     (first)
import           Data.ByteString    (ByteString)
import qualified Data.ByteString    as BS
import qualified Data.List          as List
import qualified Data.Vault.Lazy    as Vault
import           GHC.IO             (unsafePerformIO)
import           Network.HTTP.Types (forbidden403, hAuthorization,
                                     unauthorized401)
import           Network.Wai        (Middleware, Request (..), Response,
                                     responseLBS)

-- | Key where the verified biscuit is stored in the request context. The
-- 'Data.Vault.Lazy' module is designed to make keys opaque and unique, hence the use of
-- 'IO' for key generation. Here we don’t care about unicity, we want the token
-- to be easily accessible. Hence the call to 'unsafePerformIO'.
{-# NOINLINE  biscuitKey #-}
biscuitKey :: Vault.Key (Biscuit OpenOrSealed Verified)
biscuitKey :: Key (Biscuit OpenOrSealed Verified)
biscuitKey = IO (Key (Biscuit OpenOrSealed Verified))
-> Key (Biscuit OpenOrSealed Verified)
forall a. IO a -> a
unsafePerformIO IO (Key (Biscuit OpenOrSealed Verified))
forall a. IO (Key a)
Vault.newKey

-- | Key where the authorized biscuit is stored in the request context. The
-- 'Data.Vault.Lazy' module is designed to make keys opaque and unique, hence the use of
-- 'IO' for key generation. Here we don’t care about unicity, we want the token
-- to be easily accessible. Hence the call to 'unsafePerformIO'.
{-# NOINLINE  authorizedBiscuitKey #-}
authorizedBiscuitKey :: Vault.Key (AuthorizedBiscuit OpenOrSealed)
authorizedBiscuitKey :: Key (AuthorizedBiscuit OpenOrSealed)
authorizedBiscuitKey = IO (Key (AuthorizedBiscuit OpenOrSealed))
-> Key (AuthorizedBiscuit OpenOrSealed)
forall a. IO a -> a
unsafePerformIO IO (Key (AuthorizedBiscuit OpenOrSealed))
forall a. IO (Key a)
Vault.newKey

-- | Retrieve the parsed token from the request context. It is meant to be used
-- in conjunction with the 'parseBiscuit' (or 'parseBiscuitWith') middleware.
-- It will not be set by the 'authorizeBiscuit'' (or 'authorizeBiscuitWith')
-- middleware.
--
-- @since 0.1.0.0
getBiscuit :: Request -> Maybe (Biscuit OpenOrSealed Verified)
getBiscuit :: Request -> Maybe (Biscuit OpenOrSealed Verified)
getBiscuit = Key (Biscuit OpenOrSealed Verified)
-> Vault -> Maybe (Biscuit OpenOrSealed Verified)
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key (Biscuit OpenOrSealed Verified)
biscuitKey (Vault -> Maybe (Biscuit OpenOrSealed Verified))
-> (Request -> Vault)
-> Request
-> Maybe (Biscuit OpenOrSealed Verified)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Vault
vault

-- | Retrieve the result of the successful authorization from the request
-- context. It is meant to be used in conjunction with the 'authorizeBiscuit''
-- (or the 'authorizeBiscuitWith') middleware.
--
-- @since 0.1.0.0
getAuthorizedBiscuit :: Request -> Maybe (AuthorizedBiscuit OpenOrSealed)
getAuthorizedBiscuit :: Request -> Maybe (AuthorizedBiscuit OpenOrSealed)
getAuthorizedBiscuit = Key (AuthorizedBiscuit OpenOrSealed)
-> Vault -> Maybe (AuthorizedBiscuit OpenOrSealed)
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key (AuthorizedBiscuit OpenOrSealed)
authorizedBiscuitKey (Vault -> Maybe (AuthorizedBiscuit OpenOrSealed))
-> (Request -> Vault)
-> Request
-> Maybe (AuthorizedBiscuit OpenOrSealed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Vault
vault

-- | Given a public key, generate a middleware that will extract a biscuit
-- token from incoming requests, parse it, and verify its signature. Requests
-- without a verified biscuit are rejected, and the verified biscuit is added
-- to the request context.
-- __The token is not authorized, only parsed and has its signature verified__.
-- Authorization is meant to be carried out in the application itself. If you
-- want to carry out authorization in the middleware, have a look at
-- 'authorizeBiscuit'' (or 'authorizeBiscuitWith').
--
-- The token is expected as a base64-encoded string, provided as a bearer token
-- in the @Authorization@ header. A missing header results in a bodyless 401
-- HTTP response. An invalid token results in a bodyless 403 HTTP response.
-- Errors are logged to stdout.
--
-- If you need custom extraction, parsing or error handling, have a look at
-- 'parseBiscuitWith'.
--
-- @since 0.1.0.0
parseBiscuit :: PublicKey -> Middleware
parseBiscuit :: PublicKey -> Middleware
parseBiscuit = ExtractionConfig BiscuitError -> Middleware
forall e. ExtractionConfig e -> Middleware
parseBiscuitWith (ExtractionConfig BiscuitError -> Middleware)
-> (PublicKey -> ExtractionConfig BiscuitError)
-> PublicKey
-> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> ExtractionConfig BiscuitError
defaultExtractionConfig

-- | Given a public key, generate a middleware that will extract a biscuit
-- token from incoming requests, parse it, and verify its signature.
--
-- Requests without a verified biscuit are __not__ rejected.
-- The verified biscuit is added to the request context (if available).
-- Requests with a token that fails parsing or verification are rejected.
-- __The token is not authorized, only parsed and has its signature verified__.
-- Authorization is meant to be carried out in the application itself. If you
-- want to carry out authorization in the middleware, have a look at
-- 'authorizeBiscuit'' (or 'authorizeBiscuitWith').
--
-- The token is expected as a base64-encoded string, provided as a bearer token
-- in the @Authorization@ header. A missing header results in a bodyless 401
-- HTTP response. An invalid token results in a bodyless 403 HTTP response.
-- Errors are logged to stdout.
--
-- If you need custom extraction, parsing or error handling, have a look at
-- 'parseBiscuitWith'.
--
-- @since 0.1.0.0
parseOptionalBiscuit :: PublicKey -> Middleware
parseOptionalBiscuit :: PublicKey -> Middleware
parseOptionalBiscuit = ExtractionConfig BiscuitError -> Middleware
forall e. ExtractionConfig e -> Middleware
parseBiscuitWith (ExtractionConfig BiscuitError -> Middleware)
-> (PublicKey -> ExtractionConfig BiscuitError)
-> PublicKey
-> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> ExtractionConfig BiscuitError
defaultOptionalExtractionConfig

-- | Given a way to extract a token from a request, parse it, and handle errors,
-- generate a middleware that will extract a biscuit token from incoming
-- requests, parse it, and verify its signature. Requests without a verified
-- biscuit are rejected, and the verified biscuit is added to the request
-- context.
-- __The token is not authorized, only parsed and has its signature verified__.
-- Authorization is meant to be carried out in the application itself. If you
-- want to carry out authorization in the middleware, have a look at
-- 'authorizeBiscuit'' (or 'authorizeBiscuitWith').
--
-- If you don’t need custom extraction, parsing or error handling logic, have a
-- look at 'parseBiscuit'.
--
-- @since 0.1.0.0
parseBiscuitWith :: ExtractionConfig e -> Middleware
parseBiscuitWith :: forall e. ExtractionConfig e -> Middleware
parseBiscuitWith ExtractionConfig e
config Application
app Request
req Response -> IO ResponseReceived
sendResponse = do
  let ExtractionConfig{Request -> IO (Either e (Maybe ByteString))
extractToken :: Request -> IO (Either e (Maybe ByteString))
$sel:extractToken:ExtractionConfig :: forall e.
ExtractionConfig e -> Request -> IO (Either e (Maybe ByteString))
extractToken,ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
$sel:parseToken:ExtractionConfig :: forall e.
ExtractionConfig e
-> ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken,e -> IO Response
handleError :: e -> IO Response
$sel:handleError:ExtractionConfig :: forall e. ExtractionConfig e -> e -> IO Response
handleError, Either e ()
onMissingBiscuit :: Either e ()
$sel:onMissingBiscuit:ExtractionConfig :: forall e. ExtractionConfig e -> Either e ()
onMissingBiscuit} = ExtractionConfig e
config
      noBiscuit :: IO (Either e (Maybe a))
noBiscuit = Either e (Maybe a) -> IO (Either e (Maybe a))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e (Maybe a) -> IO (Either e (Maybe a)))
-> Either e (Maybe a) -> IO (Either e (Maybe a))
forall a b. (a -> b) -> a -> b
$ Maybe a
forall a. Maybe a
Nothing Maybe a -> Either e () -> Either e (Maybe a)
forall a b. a -> Either e b -> Either e a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Either e ()
onMissingBiscuit
      parse :: ByteString -> IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
parse = (Either e (Biscuit OpenOrSealed Verified)
 -> Either e (Maybe (Biscuit OpenOrSealed Verified)))
-> IO (Either e (Biscuit OpenOrSealed Verified))
-> IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Biscuit OpenOrSealed Verified
 -> Maybe (Biscuit OpenOrSealed Verified))
-> Either e (Biscuit OpenOrSealed Verified)
-> Either e (Maybe (Biscuit OpenOrSealed Verified))
forall a b. (a -> b) -> Either e a -> Either e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Biscuit OpenOrSealed Verified
-> Maybe (Biscuit OpenOrSealed Verified)
forall a. a -> Maybe a
Just) (IO (Either e (Biscuit OpenOrSealed Verified))
 -> IO (Either e (Maybe (Biscuit OpenOrSealed Verified))))
-> (ByteString -> IO (Either e (Biscuit OpenOrSealed Verified)))
-> ByteString
-> IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken
      onError :: e -> IO ResponseReceived
onError = Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> (e -> IO Response) -> e -> IO ResponseReceived
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< e -> IO Response
handleError
      forward :: Maybe (Biscuit OpenOrSealed Verified) -> IO ResponseReceived
forward Maybe (Biscuit OpenOrSealed Verified)
t = do
         let oldVault :: Vault
oldVault = Request -> Vault
vault Request
req
             newVault :: Vault
newVault = (Vault -> Vault)
-> (Biscuit OpenOrSealed Verified -> Vault -> Vault)
-> Maybe (Biscuit OpenOrSealed Verified)
-> Vault
-> Vault
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Vault -> Vault
forall a. a -> a
id (Key (Biscuit OpenOrSealed Verified)
-> Biscuit OpenOrSealed Verified -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (Biscuit OpenOrSealed Verified)
biscuitKey) Maybe (Biscuit OpenOrSealed Verified)
t (Vault -> Vault) -> Vault -> Vault
forall a b. (a -> b) -> a -> b
$ Vault
oldVault
         Application
app Request
req { vault :: Vault
vault = Vault
newVault } Response -> IO ResponseReceived
sendResponse
  Either e (Maybe (Biscuit OpenOrSealed Verified))
emBiscuit <- (e -> IO (Either e (Maybe (Biscuit OpenOrSealed Verified))))
-> (Maybe ByteString
    -> IO (Either e (Maybe (Biscuit OpenOrSealed Verified))))
-> Either e (Maybe ByteString)
-> IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either e (Maybe (Biscuit OpenOrSealed Verified))
-> IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e (Maybe (Biscuit OpenOrSealed Verified))
 -> IO (Either e (Maybe (Biscuit OpenOrSealed Verified))))
-> (e -> Either e (Maybe (Biscuit OpenOrSealed Verified)))
-> e
-> IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e (Maybe (Biscuit OpenOrSealed Verified))
forall a b. a -> Either a b
Left) (IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
-> (ByteString
    -> IO (Either e (Maybe (Biscuit OpenOrSealed Verified))))
-> Maybe ByteString
-> IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
forall {a}. IO (Either e (Maybe a))
noBiscuit ByteString -> IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
parse) (Either e (Maybe ByteString)
 -> IO (Either e (Maybe (Biscuit OpenOrSealed Verified))))
-> IO (Either e (Maybe ByteString))
-> IO (Either e (Maybe (Biscuit OpenOrSealed Verified)))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request -> IO (Either e (Maybe ByteString))
extractToken Request
req
  (e -> IO ResponseReceived)
-> (Maybe (Biscuit OpenOrSealed Verified) -> IO ResponseReceived)
-> Either e (Maybe (Biscuit OpenOrSealed Verified))
-> IO ResponseReceived
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO ResponseReceived
onError Maybe (Biscuit OpenOrSealed Verified) -> IO ResponseReceived
forward Either e (Maybe (Biscuit OpenOrSealed Verified))
emBiscuit

-- | Given a public key and a way to generate an authorizer from a request,
-- generate a middleware that will extract a biscuit token from incoming
-- requests, parse it, verify its signature and authorize it. Requests without
-- an authorized biscuit are rejected, and the authorized biscuit is added to
-- the request context.
-- __The underlying application will only receive requests where the whole authorization process succeeded.__
-- If you want to only parse tokens and delegate actual authorization to the
-- underlying application, have a look at 'parseBiscuit'
-- (or 'parseBiscuitWith').
--
-- The token is expected as a base64-encoded string, provided as a bearer token
-- in the @Authorization@ header. A missing header results in a bodyless 401
-- HTTP response. An invalid token results in a bodyless 403 HTTP response. A
-- failed authorization process results in a bodyless 403 HTTP response.
-- Errors are logged to stdout.
--
-- If you need custom extraction, parsing, authorization or error handling,
-- have a look at 'authorizeBiscuitWith'.
--
-- @since 0.1.0.0
authorizeBiscuit' :: PublicKey -> (Request -> IO Authorizer) -> Middleware
authorizeBiscuit' :: PublicKey -> (Request -> IO Authorizer) -> Middleware
authorizeBiscuit' PublicKey
publicKey = AuthorizationConfig BiscuitError -> Middleware
forall e. AuthorizationConfig e -> Middleware
authorizeBiscuitWith (AuthorizationConfig BiscuitError -> Middleware)
-> ((Request -> IO Authorizer) -> AuthorizationConfig BiscuitError)
-> (Request -> IO Authorizer)
-> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey
-> (Request -> IO Authorizer) -> AuthorizationConfig BiscuitError
defaultAuthorizationConfig PublicKey
publicKey

-- | Given a way to extract a token from a request, parse it, authorized it and
-- handle errors, generate a middleware that will extract a biscuit token from
-- incoming requests, parse it, verify its signature and authorize it.
-- Requests without an authorized biscuit are rejected, and the authorized
-- biscuit is added to the request context.
-- __The underlying application will only receive requests where the whole authorization process succeeded__.
-- If you want to only parse tokens and delegate actual authorization to the
-- underlying application, have a look at 'parseBiscuit' (or
-- 'parseBiscuitWith').
--
-- If you don’t need custom extraction, parsing, authorization, or error
-- handling logic, have a look at 'authorizeBiscuit''.
--
-- @since 0.1.0.0
authorizeBiscuitWith :: AuthorizationConfig e -> Middleware
authorizeBiscuitWith :: forall e. AuthorizationConfig e -> Middleware
authorizeBiscuitWith AuthorizationConfig e
config Application
app Request
req Response -> IO ResponseReceived
sendResponse = do
  let AuthorizationConfig{Request -> IO (Either e ByteString)
extractToken :: Request -> IO (Either e ByteString)
$sel:extractToken:AuthorizationConfig :: forall e.
AuthorizationConfig e -> Request -> IO (Either e ByteString)
extractToken,ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
$sel:parseToken:AuthorizationConfig :: forall e.
AuthorizationConfig e
-> ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken,Request
-> Biscuit OpenOrSealed Verified
-> IO (Either e (AuthorizedBiscuit OpenOrSealed))
authorizeToken :: Request
-> Biscuit OpenOrSealed Verified
-> IO (Either e (AuthorizedBiscuit OpenOrSealed))
$sel:authorizeToken:AuthorizationConfig :: forall e.
AuthorizationConfig e
-> Request
-> Biscuit OpenOrSealed Verified
-> IO (Either e (AuthorizedBiscuit OpenOrSealed))
authorizeToken,e -> IO Response
handleError :: e -> IO Response
$sel:handleError:AuthorizationConfig :: forall e. AuthorizationConfig e -> e -> IO Response
handleError} = AuthorizationConfig e
config
      onError :: e -> IO ResponseReceived
onError = Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> (e -> IO Response) -> e -> IO ResponseReceived
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< e -> IO Response
handleError
      forward :: AuthorizedBiscuit OpenOrSealed -> IO ResponseReceived
forward AuthorizedBiscuit OpenOrSealed
t = do
         let newVault :: Vault
newVault = Key (AuthorizedBiscuit OpenOrSealed)
-> AuthorizedBiscuit OpenOrSealed -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (AuthorizedBiscuit OpenOrSealed)
authorizedBiscuitKey AuthorizedBiscuit OpenOrSealed
t (Request -> Vault
vault Request
req)
         Application
app Request
req { vault :: Vault
vault = Vault
newVault } Response -> IO ResponseReceived
sendResponse
  Either e (Biscuit OpenOrSealed Verified)
eBiscuit <- (e -> IO (Either e (Biscuit OpenOrSealed Verified)))
-> (ByteString -> IO (Either e (Biscuit OpenOrSealed Verified)))
-> Either e ByteString
-> IO (Either e (Biscuit OpenOrSealed Verified))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either e (Biscuit OpenOrSealed Verified)
-> IO (Either e (Biscuit OpenOrSealed Verified))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e (Biscuit OpenOrSealed Verified)
 -> IO (Either e (Biscuit OpenOrSealed Verified)))
-> (e -> Either e (Biscuit OpenOrSealed Verified))
-> e
-> IO (Either e (Biscuit OpenOrSealed Verified))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e (Biscuit OpenOrSealed Verified)
forall a b. a -> Either a b
Left) ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken (Either e ByteString
 -> IO (Either e (Biscuit OpenOrSealed Verified)))
-> IO (Either e ByteString)
-> IO (Either e (Biscuit OpenOrSealed Verified))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request -> IO (Either e ByteString)
extractToken Request
req
  Either e (AuthorizedBiscuit OpenOrSealed)
eResult <- (e -> IO (Either e (AuthorizedBiscuit OpenOrSealed)))
-> (Biscuit OpenOrSealed Verified
    -> IO (Either e (AuthorizedBiscuit OpenOrSealed)))
-> Either e (Biscuit OpenOrSealed Verified)
-> IO (Either e (AuthorizedBiscuit OpenOrSealed))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either e (AuthorizedBiscuit OpenOrSealed)
-> IO (Either e (AuthorizedBiscuit OpenOrSealed))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e (AuthorizedBiscuit OpenOrSealed)
 -> IO (Either e (AuthorizedBiscuit OpenOrSealed)))
-> (e -> Either e (AuthorizedBiscuit OpenOrSealed))
-> e
-> IO (Either e (AuthorizedBiscuit OpenOrSealed))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e (AuthorizedBiscuit OpenOrSealed)
forall a b. a -> Either a b
Left) (Request
-> Biscuit OpenOrSealed Verified
-> IO (Either e (AuthorizedBiscuit OpenOrSealed))
authorizeToken Request
req) Either e (Biscuit OpenOrSealed Verified)
eBiscuit
  (e -> IO ResponseReceived)
-> (AuthorizedBiscuit OpenOrSealed -> IO ResponseReceived)
-> Either e (AuthorizedBiscuit OpenOrSealed)
-> IO ResponseReceived
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO ResponseReceived
onError AuthorizedBiscuit OpenOrSealed -> IO ResponseReceived
forward Either e (AuthorizedBiscuit OpenOrSealed)
eResult

-- | Configuration for 'parseBiscuitWith'.
--
-- @since 0.1.0.0
data ExtractionConfig e
  = ExtractionConfig
  -- | How to extract a token from a request
  { forall e.
ExtractionConfig e -> Request -> IO (Either e (Maybe ByteString))
extractToken :: Request -> IO (Either e (Maybe ByteString))
  -- | How to parse a token from the extracted serialized bytestring
  , forall e.
ExtractionConfig e
-> ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken   :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
  -- | How to handle errors (this does not allow recovery)
  , forall e. ExtractionConfig e -> e -> IO Response
handleError  :: e -> IO Response
  -- | How to handle requests with no biscuits
  , forall e. ExtractionConfig e -> Either e ()
onMissingBiscuit :: Either e ()
  }

-- | Configuration for 'authorizeBiscuitWith'.
--
-- @since 0.1.0.0
data AuthorizationConfig e
  = AuthorizationConfig
  -- | How to extract a token from a request
  { forall e.
AuthorizationConfig e -> Request -> IO (Either e ByteString)
extractToken :: Request -> IO (Either e ByteString)
  -- | How to parse a token from the extracted serialized bytestring
  , forall e.
AuthorizationConfig e
-> ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken   :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
  -- | How to authorize a token
  , forall e.
AuthorizationConfig e
-> Request
-> Biscuit OpenOrSealed Verified
-> IO (Either e (AuthorizedBiscuit OpenOrSealed))
authorizeToken :: Request -> Biscuit OpenOrSealed Verified -> IO (Either e (AuthorizedBiscuit OpenOrSealed))
  -- | How to handle errors (this does not allow recovery)
  , forall e. AuthorizationConfig e -> e -> IO Response
handleError  :: e -> IO Response
  }

-- | Errors that can happen during token authorization
--
-- @since 0.1.0.0
data BiscuitError
  -- | No token was provided
  = NoToken
  -- | The provided token could not be parsed or verified
  | ParseError ParseError
  -- | The provided token was successfully parsed, but authorization failed
  | AuthorizationError ExecutionError

-- | Default behaviour for token extraction and parsing.
--
-- - Extract the token as a bearer token from the @Authorization@ header;
-- - Parse the token as URL-safe base64 strings, using the provided public
--   key;
-- - Errors are logged to stdout;
-- - Missing tokens are rejected with a bodyless 401 HTTP response;
-- - Parsing errors are rejected with a bodyless 403 HTTP response.
--
-- @since 0.1.0.0
defaultExtractionConfig :: PublicKey -> ExtractionConfig BiscuitError
defaultExtractionConfig :: PublicKey -> ExtractionConfig BiscuitError
defaultExtractionConfig PublicKey
publicKey = ExtractionConfig
  { $sel:extractToken:ExtractionConfig :: Request -> IO (Either BiscuitError (Maybe ByteString))
extractToken = Either BiscuitError (Maybe ByteString)
-> IO (Either BiscuitError (Maybe ByteString))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BiscuitError (Maybe ByteString)
 -> IO (Either BiscuitError (Maybe ByteString)))
-> (Request -> Either BiscuitError (Maybe ByteString))
-> Request
-> IO (Either BiscuitError (Maybe ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> Either BiscuitError (Maybe ByteString)
forall a b. b -> Either a b
Right (Maybe ByteString -> Either BiscuitError (Maybe ByteString))
-> (Request -> Maybe ByteString)
-> Request
-> Either BiscuitError (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Maybe ByteString
defaultExtractToken
  , $sel:parseToken:ExtractionConfig :: ByteString
-> IO (Either BiscuitError (Biscuit OpenOrSealed Verified))
parseToken = Either BiscuitError (Biscuit OpenOrSealed Verified)
-> IO (Either BiscuitError (Biscuit OpenOrSealed Verified))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BiscuitError (Biscuit OpenOrSealed Verified)
 -> IO (Either BiscuitError (Biscuit OpenOrSealed Verified)))
-> (ByteString
    -> Either BiscuitError (Biscuit OpenOrSealed Verified))
-> ByteString
-> IO (Either BiscuitError (Biscuit OpenOrSealed Verified))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseError -> BiscuitError)
-> Either ParseError (Biscuit OpenOrSealed Verified)
-> Either BiscuitError (Biscuit OpenOrSealed Verified)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Data.Bifunctor.first ParseError -> BiscuitError
ParseError (Either ParseError (Biscuit OpenOrSealed Verified)
 -> Either BiscuitError (Biscuit OpenOrSealed Verified))
-> (ByteString
    -> Either ParseError (Biscuit OpenOrSealed Verified))
-> ByteString
-> Either BiscuitError (Biscuit OpenOrSealed Verified)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey
-> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)
parseB64 PublicKey
publicKey
  , $sel:handleError:ExtractionConfig :: BiscuitError -> IO Response
handleError = BiscuitError -> IO Response
defaultHandleError
  , $sel:onMissingBiscuit:ExtractionConfig :: Either BiscuitError ()
onMissingBiscuit = BiscuitError -> Either BiscuitError ()
forall a b. a -> Either a b
Left BiscuitError
NoToken
  }

-- | Default behaviour for optional token extraction and parsing.
--
-- - Extract the token as a bearer token from the @Authorization@ header;
-- - Parse the token as URL-safe base64 strings, using the provided public
--   key;
-- - Errors are logged to stdout;
-- - Missing tokens are not rejected;
-- - Parsing errors are rejected with a bodyless 403 HTTP response.
--
-- @since 0.1.0.0
defaultOptionalExtractionConfig :: PublicKey -> ExtractionConfig BiscuitError
defaultOptionalExtractionConfig :: PublicKey -> ExtractionConfig BiscuitError
defaultOptionalExtractionConfig PublicKey
publicKey = ExtractionConfig
  { $sel:extractToken:ExtractionConfig :: Request -> IO (Either BiscuitError (Maybe ByteString))
extractToken = Either BiscuitError (Maybe ByteString)
-> IO (Either BiscuitError (Maybe ByteString))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BiscuitError (Maybe ByteString)
 -> IO (Either BiscuitError (Maybe ByteString)))
-> (Request -> Either BiscuitError (Maybe ByteString))
-> Request
-> IO (Either BiscuitError (Maybe ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> Either BiscuitError (Maybe ByteString)
forall a b. b -> Either a b
Right (Maybe ByteString -> Either BiscuitError (Maybe ByteString))
-> (Request -> Maybe ByteString)
-> Request
-> Either BiscuitError (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Maybe ByteString
defaultExtractToken
  , $sel:parseToken:ExtractionConfig :: ByteString
-> IO (Either BiscuitError (Biscuit OpenOrSealed Verified))
parseToken = Either BiscuitError (Biscuit OpenOrSealed Verified)
-> IO (Either BiscuitError (Biscuit OpenOrSealed Verified))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BiscuitError (Biscuit OpenOrSealed Verified)
 -> IO (Either BiscuitError (Biscuit OpenOrSealed Verified)))
-> (ByteString
    -> Either BiscuitError (Biscuit OpenOrSealed Verified))
-> ByteString
-> IO (Either BiscuitError (Biscuit OpenOrSealed Verified))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseError -> BiscuitError)
-> Either ParseError (Biscuit OpenOrSealed Verified)
-> Either BiscuitError (Biscuit OpenOrSealed Verified)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Data.Bifunctor.first ParseError -> BiscuitError
ParseError (Either ParseError (Biscuit OpenOrSealed Verified)
 -> Either BiscuitError (Biscuit OpenOrSealed Verified))
-> (ByteString
    -> Either ParseError (Biscuit OpenOrSealed Verified))
-> ByteString
-> Either BiscuitError (Biscuit OpenOrSealed Verified)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey
-> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)
parseB64 PublicKey
publicKey
  , $sel:handleError:ExtractionConfig :: BiscuitError -> IO Response
handleError = BiscuitError -> IO Response
defaultHandleError
  , $sel:onMissingBiscuit:ExtractionConfig :: Either BiscuitError ()
onMissingBiscuit = () -> Either BiscuitError ()
forall a b. b -> Either a b
Right ()
  }

-- | Default behaviour for token extraction, parsing and authorization.
--
-- - Extract the token as a bearer token from the @Authorization@ header;
-- - Parse the token as URL-safe base64 strings, using the provided public
--   key;
-- - Authorize the request with the generated authorizer;
-- - Errors are logged to stdout;
-- - Missing tokens are rejected with a bodyless 401 HTTP response;
-- - Parsing errors are rejected with a bodyless 403 HTTP response.
-- - Authorization errors are rejected with a bodyless 403 HTTP response.
--
-- @since 0.1.0.0
defaultAuthorizationConfig :: PublicKey -> (Request -> IO Authorizer) -> AuthorizationConfig BiscuitError
defaultAuthorizationConfig :: PublicKey
-> (Request -> IO Authorizer) -> AuthorizationConfig BiscuitError
defaultAuthorizationConfig PublicKey
publicKey Request -> IO Authorizer
mkAuthorizer = AuthorizationConfig
  { $sel:extractToken:AuthorizationConfig :: Request -> IO (Either BiscuitError ByteString)
extractToken = Either BiscuitError ByteString
-> IO (Either BiscuitError ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BiscuitError ByteString
 -> IO (Either BiscuitError ByteString))
-> (Request -> Either BiscuitError ByteString)
-> Request
-> IO (Either BiscuitError ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either BiscuitError ByteString
-> (ByteString -> Either BiscuitError ByteString)
-> Maybe ByteString
-> Either BiscuitError ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BiscuitError -> Either BiscuitError ByteString
forall a b. a -> Either a b
Left BiscuitError
NoToken) ByteString -> Either BiscuitError ByteString
forall a b. b -> Either a b
Right (Maybe ByteString -> Either BiscuitError ByteString)
-> (Request -> Maybe ByteString)
-> Request
-> Either BiscuitError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Maybe ByteString
defaultExtractToken
  , $sel:parseToken:AuthorizationConfig :: ByteString
-> IO (Either BiscuitError (Biscuit OpenOrSealed Verified))
parseToken = Either BiscuitError (Biscuit OpenOrSealed Verified)
-> IO (Either BiscuitError (Biscuit OpenOrSealed Verified))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BiscuitError (Biscuit OpenOrSealed Verified)
 -> IO (Either BiscuitError (Biscuit OpenOrSealed Verified)))
-> (ByteString
    -> Either BiscuitError (Biscuit OpenOrSealed Verified))
-> ByteString
-> IO (Either BiscuitError (Biscuit OpenOrSealed Verified))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseError -> BiscuitError)
-> Either ParseError (Biscuit OpenOrSealed Verified)
-> Either BiscuitError (Biscuit OpenOrSealed Verified)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Data.Bifunctor.first ParseError -> BiscuitError
ParseError (Either ParseError (Biscuit OpenOrSealed Verified)
 -> Either BiscuitError (Biscuit OpenOrSealed Verified))
-> (ByteString
    -> Either ParseError (Biscuit OpenOrSealed Verified))
-> ByteString
-> Either BiscuitError (Biscuit OpenOrSealed Verified)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey
-> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)
parseB64 PublicKey
publicKey
  , $sel:authorizeToken:AuthorizationConfig :: Request
-> Biscuit OpenOrSealed Verified
-> IO (Either BiscuitError (AuthorizedBiscuit OpenOrSealed))
authorizeToken = \Request
req Biscuit OpenOrSealed Verified
token -> (ExecutionError -> BiscuitError)
-> Either ExecutionError (AuthorizedBiscuit OpenOrSealed)
-> Either BiscuitError (AuthorizedBiscuit OpenOrSealed)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ExecutionError -> BiscuitError
AuthorizationError (Either ExecutionError (AuthorizedBiscuit OpenOrSealed)
 -> Either BiscuitError (AuthorizedBiscuit OpenOrSealed))
-> IO (Either ExecutionError (AuthorizedBiscuit OpenOrSealed))
-> IO (Either BiscuitError (AuthorizedBiscuit OpenOrSealed))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Biscuit OpenOrSealed Verified
-> Authorizer
-> IO (Either ExecutionError (AuthorizedBiscuit OpenOrSealed))
forall proof.
Biscuit proof Verified
-> Authorizer
-> IO (Either ExecutionError (AuthorizedBiscuit proof))
authorizeBiscuit Biscuit OpenOrSealed Verified
token (Authorizer
 -> IO (Either ExecutionError (AuthorizedBiscuit OpenOrSealed)))
-> IO Authorizer
-> IO (Either ExecutionError (AuthorizedBiscuit OpenOrSealed))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request -> IO Authorizer
mkAuthorizer Request
req)
  , $sel:handleError:AuthorizationConfig :: BiscuitError -> IO Response
handleError = BiscuitError -> IO Response
defaultHandleError
  }

-- | Extract a token from the @Authorization@ header, stripping the @Bearer @
-- prefix.
--
-- @since 0.1.0.0
defaultExtractToken :: Request -> Maybe ByteString
defaultExtractToken :: Request -> Maybe ByteString
defaultExtractToken Request
req = do
  (HeaderName
_, ByteString
authHeader) <- ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hAuthorization) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (ResponseHeaders -> Maybe (HeaderName, ByteString))
-> ResponseHeaders -> Maybe (HeaderName, ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req
  ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"Bearer " ByteString
authHeader

-- | Generate HTTP responses based on authorization errors. Errors are logged
-- to stdout.
--
-- - Missing tokens result in a 401 bodyless response;
-- - Parsing errors result in a 403 bodyless response;
-- - Authorization errors result in a 403 bodyless response.
--
-- @since 0.1.0.0
defaultHandleError :: BiscuitError -> IO Response
defaultHandleError :: BiscuitError -> IO Response
defaultHandleError = \case
  BiscuitError
NoToken      -> do
    String -> IO ()
putStrLn String
"Missing biscuit token"
    Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
unauthorized401 ResponseHeaders
forall a. Monoid a => a
mempty ByteString
forall a. Monoid a => a
mempty
  ParseError ParseError
e -> do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Parsing or verification error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseError -> String
forall a. Show a => a -> String
show ParseError
e
    Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
forbidden403 ResponseHeaders
forall a. Monoid a => a
mempty ByteString
forall a. Monoid a => a
mempty
  AuthorizationError ExecutionError
e -> do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Authorization error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ExecutionError -> String
forall a. Show a => a -> String
show ExecutionError
e
    Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
forbidden403 ResponseHeaders
forall a. Monoid a => a
mempty ByteString
forall a. Monoid a => a
mempty