{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
module Network.Wai.Middleware.Biscuit
  (
  -- * Biscuit parsing
    parseBiscuit
  , getBiscuit
  , parseBiscuitWith
  , ExtractionConfig (..)
  , defaultExtractionConfig
  -- * Biscuit authorization
  , authorizeBiscuit'
  , getAuthorizedBiscuit
  , authorizeBiscuitWith
  , AuthorizationConfig (..)
  , defaultAuthorizationConfig
  -- * Helpers
  , defaultExtractToken
  , defaultHandleError
  ) 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
-- 'Vault' 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 = forall a. IO a -> a
unsafePerformIO forall a. IO (Key a)
Vault.newKey

-- | Key where the authorized biscuit is stored in the request context. The
-- 'Vault' 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 = forall a. IO a -> a
unsafePerformIO 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.
getBiscuit :: Request -> Maybe (Biscuit OpenOrSealed Verified)
getBiscuit :: Request -> Maybe (Biscuit OpenOrSealed Verified)
getBiscuit = forall a. Key a -> Vault -> Maybe a
Vault.lookup Key (Biscuit OpenOrSealed Verified)
biscuitKey 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.
getAuthorizedBiscuit :: Request -> Maybe (AuthorizedBiscuit OpenOrSealed)
getAuthorizedBiscuit :: Request -> Maybe (AuthorizedBiscuit OpenOrSealed)
getAuthorizedBiscuit = forall a. Key a -> Vault -> Maybe a
Vault.lookup Key (AuthorizedBiscuit OpenOrSealed)
authorizedBiscuitKey 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'.
parseBiscuit :: PublicKey -> Middleware
parseBiscuit :: PublicKey -> Middleware
parseBiscuit = forall e. ExtractionConfig e -> Middleware
parseBiscuitWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> ExtractionConfig BiscuitError
defaultExtractionConfig

-- | 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'.
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 ByteString)
$sel:extractToken:ExtractionConfig :: forall e. ExtractionConfig e -> Request -> IO (Either e ByteString)
extractToken :: Request -> IO (Either e ByteString)
extractToken,ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
$sel:parseToken:ExtractionConfig :: forall e.
ExtractionConfig e
-> ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken,e -> IO Response
$sel:handleError:ExtractionConfig :: forall e. ExtractionConfig e -> e -> IO Response
handleError :: e -> IO Response
handleError} = ExtractionConfig e
config
      onError :: e -> IO ResponseReceived
onError = Response -> IO ResponseReceived
sendResponse forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< e -> IO Response
handleError
      forward :: Biscuit OpenOrSealed Verified -> IO ResponseReceived
forward Biscuit OpenOrSealed Verified
t = do
         let newVault :: Vault
newVault = forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (Biscuit OpenOrSealed Verified)
biscuitKey Biscuit OpenOrSealed Verified
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 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request -> IO (Either e ByteString)
extractToken Request
req
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO ResponseReceived
onError Biscuit OpenOrSealed Verified -> IO ResponseReceived
forward Either e (Biscuit OpenOrSealed Verified)
eBiscuit

-- | 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'.
authorizeBiscuit' :: PublicKey -> (Request -> IO Authorizer) -> Middleware
authorizeBiscuit' :: PublicKey -> (Request -> IO Authorizer) -> Middleware
authorizeBiscuit' PublicKey
publicKey = forall e. AuthorizationConfig e -> Middleware
authorizeBiscuitWith 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''.
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)
$sel:extractToken:AuthorizationConfig :: forall e.
AuthorizationConfig e -> Request -> IO (Either e ByteString)
extractToken :: Request -> IO (Either e ByteString)
extractToken,ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
$sel:parseToken:AuthorizationConfig :: forall e.
AuthorizationConfig e
-> ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken,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 :: Request
-> Biscuit OpenOrSealed Verified
-> IO (Either e (AuthorizedBiscuit OpenOrSealed))
authorizeToken,e -> IO Response
$sel:handleError:AuthorizationConfig :: forall e. AuthorizationConfig e -> e -> IO Response
handleError :: e -> IO Response
handleError} = AuthorizationConfig e
config
      onError :: e -> IO ResponseReceived
onError = Response -> IO ResponseReceived
sendResponse 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 = 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 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
parseToken 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 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
  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'.
data ExtractionConfig e
  = ExtractionConfig
  -- | How to extract a token from a request
  { forall e. ExtractionConfig e -> Request -> IO (Either e ByteString)
extractToken :: Request -> IO (Either e 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
  }

-- | Configuration for 'authorizeBiscuitWith'.
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
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.
defaultExtractionConfig :: PublicKey -> ExtractionConfig BiscuitError
defaultExtractionConfig :: PublicKey -> ExtractionConfig BiscuitError
defaultExtractionConfig PublicKey
publicKey = ExtractionConfig
  { $sel:extractToken:ExtractionConfig :: Request -> IO (Either BiscuitError ByteString)
extractToken = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left BiscuitError
NoToken) forall a b. b -> Either a b
Right 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Data.Bifunctor.first ParseError -> BiscuitError
ParseError 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
  }

-- | 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.
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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left BiscuitError
NoToken) forall a b. b -> Either a b
Right 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Data.Bifunctor.first ParseError -> BiscuitError
ParseError 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 -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ExecutionError -> BiscuitError
AuthorizationError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall proof.
Biscuit proof Verified
-> Authorizer
-> IO (Either ExecutionError (AuthorizedBiscuit proof))
authorizeBiscuit Biscuit OpenOrSealed Verified
token 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.
defaultExtractToken :: Request -> Maybe ByteString
defaultExtractToken :: Request -> Maybe ByteString
defaultExtractToken Request
req = do
  (HeaderName
_, ByteString
authHeader) <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
== HeaderName
hAuthorization) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) 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.
defaultHandleError :: BiscuitError -> IO Response
defaultHandleError :: BiscuitError -> IO Response
defaultHandleError = \case
  BiscuitError
NoToken      -> do
    String -> IO ()
putStrLn String
"Missing biscuit token"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
unauthorized401 forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  ParseError ParseError
e -> do
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Parsing or verification error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ParseError
e
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
forbidden403 forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  AuthorizationError ExecutionError
e -> do
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Authorization error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ExecutionError
e
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
forbidden403 forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty