{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeFamilies      #-}
module Auth.Biscuit.Servant
  (
  -- * Protecting a servant API with biscuits
  -- $presentation

  -- ** Annotating servant API types
  -- $apitypes
    RequireBiscuit
  , authHandler
  , genBiscuitCtx
  -- *** Custom parsing and error handling
  , authHandlerWith
  , genBiscuitCtxWith
  , BiscuitConfig (..)
  , defaultBiscuitConfig
  -- ** Supplying a authorizer for a single endpoint
  -- $singleEndpointAuthorizer
  , checkBiscuit
  , checkBiscuitM
  -- *** Custom parsing and error handling
  , checkBiscuitWith
  , checkBiscuitMWith
  -- ** Decorate regular handlers with composable authorizers
  -- $composableAuthorizers
  , WithAuthorizer' (..)
  , WithAuthorizer
  , handleBiscuit
  , handleBiscuitWith
  , withAuthorizer
  , withAuthorizer_
  , withAuthorizerM
  , withAuthorizerM_
  , noAuthorizer
  , noAuthorizer_
  , withFallbackAuthorizer
  , withPriorityAuthorizer
  , withFallbackAuthorizerM
  , withPriorityAuthorizerM
  -- *** Extract information from an authorized token
  -- $tokenPostProcessing
  , withTransformation

  , module Biscuit
  ) where

import           Auth.Biscuit                     as Biscuit
import           Control.Applicative              (liftA2)
import           Control.Monad.Except             (MonadError, throwError)
import           Control.Monad.IO.Class           (MonadIO, liftIO)
import           Control.Monad.Reader             (ReaderT (..), lift,
                                                   runReaderT, withReaderT)
import           Data.ByteString                  (ByteString)
import qualified Data.ByteString                  as BS
import qualified Data.ByteString.Char8            as C8
import qualified Data.ByteString.Lazy             as LBS
import           Data.Either                      (fromRight)
import           Data.Kind                        (Type)
import           Network.Wai
import           Servant                          (AuthProtect)
import           Servant.Server
import           Servant.Server.Experimental.Auth

-- $presentation
--
-- Biscuit are bearer tokens that can be used to protect API endpoints.
-- This package provides utilities to protect servant endpoints with such
-- tokens.
--
-- The token will be extracted from the @Authorization@ header, and must
-- be base64-encoded, prefixed with the @Bearer @ string.

-- $apitypes
--
-- To protect an endpoint (or a whole API tree), you can use 'RequireBiscuit'
-- like so:
--
-- > type API = RequireBiscuit :> ProtectedAPI
-- > type ProtectedAPI =
-- >        "endpoint1" :> Get '[JSON] Int
-- >   :<|> "endpoint2" :> Capture "int" Int :> Get '[JSON] Int
-- >   :<|> "endpoint3" :> Get '[JSON] Int
-- >   :<|> "endpoint4" :> Get '[JSON] Int
-- >
-- > app :: PublicKey -> Application
-- > app publicKey =
-- >   -- servant needs access to the biscuit /public/
-- >   -- key to be able to check biscuit signatures.
-- >   -- The public key can be read from the environment
-- >   -- and parsed using 'parsePublicKeyHex' for instance.
-- >   serveWithContext
-- >     (Proxy :: Proxy API)
-- >     (genBiscuitCtx publicKey)
-- >     server
-- >
-- > -- server :: Biscuit OpenOrSealed Verified -> Server ProtectedAPI
-- > server :: Server API
-- > server biscuit = … -- this will be detailed later
--
-- This will instruct servant to extract the biscuit from the requests and
-- check its signature. /It will not/, however, run any datalog check (as
-- the checks typically depend on the request contents).
--
-- $singleEndpointAuthorizer
--
-- The corresponding @Server API@ value will be a @Biscuit OpenOrSealed Verified -> Server ProtectedAPI@.
-- The next step is to provide a 'Authorizer' so that the biscuit datalog can be
-- verified. For that, you can use 'checkBiscuit' (or 'checkBiscuitM' for effectful checks).
--
-- > server :: Server API
-- > server biscuit = h1 biscuit
-- >             :<|> h2 biscuit
-- >             :<|> h3 biscuit
-- >
-- > h1 :: Biscuit OpenOrSealed Verified -> Handler Int
-- > h1 biscuit =
-- >   checkBiscuit biscuit
-- >     [authorizer|allow if right("one");|]
-- >     -- ^ only allow biscuits granting access to the endpoint tagged "one"
-- >     (pure 1)
-- >
-- > h2 :: Biscuit OpenOrSealed Verified -> Int -> Handler Int
-- > h2 biscuit value =
-- >   let authorizer' = do
-- >         now <- liftIO getCurrentTime
-- >         pure [authorizer|
-- >                // provide the current time so that TTL checks embedded in
-- >                // the biscuit can decide if it's still valid
-- >                // this show how to run an effectful check with
-- >                // checkBiscuitM (getting the current time is an effect)
-- >                time({now});
-- >                // only allow biscuits granting access to the endpoint tagged "two"
-- >                // AND for the provided int value. This shows how the checks can depend
-- >                // on the http request contents.
-- >                allow if right("two", {value});
-- >              |]
-- >   checkBiscuitM biscuit authorizer
-- >     (pure 2)
-- >
-- > h3 :: Biscuit OpenOrSealed Verified -> Handler Int
-- > h3 biscuit =
-- >   checkBiscuit biscuit
-- >     [authorizer|deny if true;|]
-- >     -- ^ reject every biscuit
-- >     (pure 3)
--
-- $composableAuthorizers
--
-- 'checkBiscuit' allows you to describe validation rules endpoint by endpoint. If your
-- application has a lot of endpoints with the same policies, it can become tedious to
-- maintain.
--
-- 'biscuit-servant' provides a way to apply authorizers on whole API trees,
-- in a composable way, thanks to 'hoistServer'. 'hoistServer' is a mechanism
-- provided by servant-server that lets apply a transformation function to whole
-- API trees.
--
-- > -- 'withAuthorizer' wraps a 'Handler' and lets you attach a authorizer to a
-- > -- specific endoint. This authorizer may be combined with other authorizers
-- > -- attached to the whole API tree
-- > handler1 :: WithAuthorizer Handler Int
-- > handler1 = withAuthorizer
-- >   [authorizer|allow if right("one");|]
-- >   (pure 1)
-- >
-- > handler2 :: Int -> WithAuthorizer Handler Int
-- > handler2 value = withAuthorizer
-- >   [authorizer|allow if right("two", {value});|]
-- >   (pure 2)
-- >
-- > handler3 :: WithAuthorizer Handler Int
-- > handler3 = withAuthorizer
-- >   [authorizer|deny if true;|]
-- >   (pure 3)
-- >
-- > server :: Biscuit OpenOrSealed Verified -> Server ProtectedAPI
-- > server biscuit =
-- >  let nowFact = do
-- >        now <- liftIO getCurrentTime
-- >        pure [authorizer|time({now});|]
-- >      handleAuth :: WithAuthorizer Handler x -> Handler x
-- >      handleAuth =
-- >          handleBiscuit biscuit
-- >          -- ^ this runs datalog checks on the biscuit, based on authorizers attached to
-- >          -- the handlers
-- >        . withPriorityAuthorizerM nowFact
-- >          -- ^ this provides the current time to the verification context so that biscuits with
-- >          -- a TTL can check if they are still valid.
-- >          -- Authorizers can be provided in a monadic context (it has to be the same monad as
-- >          -- the handlers themselves, so here it's 'Handler').
-- >        . withPriorityAuthorizer [authorizer|allow if right("admin");|]
-- >          -- ^ this policy will be tried /before/ any endpoint policy, so `endpoint3` will be
-- >          -- reachable with an admin biscuit
-- >        . withFallbackAuthorizer [authorizer|allow if right("anon");|]
-- >          -- ^ this policy will be tried /after/ the endpoints policies, so `endpoint3` will
-- >          -- *not* be reachable with an anon macaroon.
-- >      handlers = handler1 :<|> handler2 :<|> handler3
-- >   in hoistServer @ProtectedAPI Proxy handleAuth handlers
-- >        -- ^ this will apply `handleAuth` on all 'ProtectedAPI' endpoints.
--
-- $tokenPostProcessing
--
-- By default, an `AuthorizedBiscuit` value is available through `MonadReader` in all
-- `WithAuthorizer` handlers. In many cases, a post-processing step is needed to extract
-- meaningful information from the token (for instance extracting a user id and then fetching
-- user information from the database). In order to avoid repeating this operation in every
-- endpoint, `withTransformation` allows to do it for whole API trees.
--
-- > handler4 :: WithAuthorizer Handler Int
-- > handler4 = withTransformation extractUserId $
-- >   withAuthorizer [authorizer|allow if user($user_id); |] $ do
-- >     userId <- ask -- we can access the extracted user id directly
-- >     pure userId
-- >
-- > -- given a @AuthorizedBiscuit OpenOrSealed@, we can extract information from
-- > -- the token. This step can perform effects (for instance `IO`, or `MonadError`).
-- > extractUserId :: AuthorizedBiscuit OpenOrSealed -> Handler Int
-- > extractUserId AuthorizedBiscuit{authorizationSuccess} = do
-- >   let b = bindings $ matchedAllowQuery authorizationSuccess
-- >    in maybe (throwError err403) pure $ getSingleVariableValue b "user_id"

-- | Type used to protect an API tree, requiring a biscuit token
-- to be attached to requests. The associated auth handler will
-- only check the biscuit signature. Checking the datalog part
-- usually requires endpoint-specific information, and has to
-- be performed separately with either 'checkBiscuit' (for simple
-- use-cases) or 'handleBiscuit' (for more complex use-cases).
type RequireBiscuit = AuthProtect "biscuit"

-- | The result of a 'RequireBiscuit' check will be a @Biscuit OpenOrSealed Verified@:
-- a biscuit that's been successfully parsed, with its signatures verified.
type instance AuthServerData RequireBiscuit = Biscuit OpenOrSealed Verified

-- | Wrapper for a servant handler, equipped with a biscuit 'Authorizer'
-- that will be used to authorize the request. If the authorization
-- succeeds, the handler is ran.
-- The handler itself is given access to the authorized biscuit (or another
-- value derived from it) through a @ReaderT@ wrapper
data WithAuthorizer' (t :: Type) (m :: Type -> Type) (a :: Type)
  = WithAuthorizer
  { forall t (m :: * -> *) a. WithAuthorizer' t m a -> ReaderT t m a
handler_    :: ReaderT t m a
  -- ^ the wrapped handler, in a 'ReaderT' to give easy access to the biscuit
  , forall t (m :: * -> *) a. WithAuthorizer' t m a -> m Authorizer
authorizer_ :: m Authorizer
  -- ^ the 'Authorizer' associated to the handler
  }

-- | Default wrapper giving access to the @AuthorizedBiscuit@ directly.
type WithAuthorizer = WithAuthorizer' (AuthorizedBiscuit OpenOrSealed)

-- | Combines the provided 'Authorizer' to the 'Authorizer' attached to the wrapped
-- handler. /facts/, /rules/ and /checks/ are unordered, but /policies/ have a
-- specific order. 'withFallbackAuthorizer' puts the provided policies at the /bottom/
-- of the list (ie as /fallback/ policies): these policies will be tried /after/
-- the policies declared through 'withPriorityAuthorizer' and after the policies
-- declared by the endpoints.
--
-- If you want the policies to be tried before the ones of the wrapped handler, you
-- can use 'withPriorityAuthorizer'.
--
-- If you need to perform effects to compute the authorizer (eg. to get the current date,
-- or to query a database), you can use 'withFallbackAuthorizerM' instead.
withFallbackAuthorizer :: Functor m
                     => Authorizer
                     -> WithAuthorizer' t m a
                     -> WithAuthorizer' t m a
withFallbackAuthorizer :: forall (m :: * -> *) t a.
Functor m =>
Authorizer -> WithAuthorizer' t m a -> WithAuthorizer' t m a
withFallbackAuthorizer Authorizer
newV h :: WithAuthorizer' t m a
h@WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall t (m :: * -> *) a. WithAuthorizer' t m a -> m Authorizer
authorizer_} =
  WithAuthorizer' t m a
h { authorizer_ :: m Authorizer
authorizer_ = (forall a. Semigroup a => a -> a -> a
<> Authorizer
newV) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Authorizer
authorizer_ }

-- | Combines the provided 'Authorizer' to the 'Authorizer' attached to the wrapped
-- handler. /facts/, /rules/ and /checks/ are unordered, but /policies/ have a
-- specific order. 'withFallbackAuthorizer' puts the provided policies at the /bottom/
-- of the list (ie as /fallback/ policies): these policies will be tried /after/
-- the policies declared through 'withPriorityAuthorizer' and after the policies
-- declared by the endpoints.
--
-- If you want the policies to be tried before the ones of the wrapped handler, you
-- can use 'withPriorityAuthorizer'.
--
-- Here, the 'Authorizer' can be computed effectfully. If you don't need to perform effects,
-- you can use 'withFallbackAuthorizer' instead.
withFallbackAuthorizerM :: Applicative m
                      => m Authorizer
                      -> WithAuthorizer' t m a
                      -> WithAuthorizer' t m a
withFallbackAuthorizerM :: forall (m :: * -> *) t a.
Applicative m =>
m Authorizer -> WithAuthorizer' t m a -> WithAuthorizer' t m a
withFallbackAuthorizerM m Authorizer
newV h :: WithAuthorizer' t m a
h@WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall t (m :: * -> *) a. WithAuthorizer' t m a -> m Authorizer
authorizer_} =
  WithAuthorizer' t m a
h { authorizer_ :: m Authorizer
authorizer_ = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>) m Authorizer
authorizer_ m Authorizer
newV }

-- | Combines the provided 'Authorizer' to the 'Authorizer' attached to the wrapped
-- handler. /facts/, /rules/ and /checks/ are unordered, but /policies/ have a
-- specific order. 'withFallbackAuthorizer' puts the provided policies at the /top/
-- of the list (ie as /priority/ policies): these policies will be tried /after/
-- the policies declared through 'withPriorityAuthorizer' and after the policies
-- declared by the endpoints.
--
-- If you want the policies to be tried after the ones of the wrapped handler, you
-- can use 'withFallbackAuthorizer'.
--
-- If you need to perform effects to compute the authorizer (eg. to get the current date,
-- or to query a database), you can use 'withPriorityAuthorizerM' instead.
withPriorityAuthorizer :: Functor m
                     => Authorizer
                     -> WithAuthorizer m a
                     -> WithAuthorizer m a
withPriorityAuthorizer :: forall (m :: * -> *) a.
Functor m =>
Authorizer -> WithAuthorizer m a -> WithAuthorizer m a
withPriorityAuthorizer Authorizer
newV h :: WithAuthorizer m a
h@WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall t (m :: * -> *) a. WithAuthorizer' t m a -> m Authorizer
authorizer_} =
     WithAuthorizer m a
h { authorizer_ :: m Authorizer
authorizer_ = (Authorizer
newV forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Authorizer
authorizer_ }

-- | Combines the provided 'Authorizer' to the 'Authorizer' attached to the wrapped
-- handler. /facts/, /rules/ and /checks/ are unordered, but /policies/ have a
-- specific order. 'withFallbackAuthorizer' puts the provided policies at the /top/
-- of the list (ie as /priority/ policies): these policies will be tried /after/
-- the policies declared through 'withPriorityAuthorizer' and after the policies
-- declared by the endpoints.
--
-- If you want the policies to be tried after the ones of the wrapped handler, you
-- can use 'withFallbackAuthorizer'.
--
-- Here, the 'Authorizer' can be computed effectfully. If you don't need to perform effects,
-- you can use 'withFallbackAuthorizer' instead.
withPriorityAuthorizerM :: Applicative m
                      => m Authorizer
                      -> WithAuthorizer' t m a
                      -> WithAuthorizer' t m a
withPriorityAuthorizerM :: forall (m :: * -> *) t a.
Applicative m =>
m Authorizer -> WithAuthorizer' t m a -> WithAuthorizer' t m a
withPriorityAuthorizerM m Authorizer
newV h :: WithAuthorizer' t m a
h@WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall t (m :: * -> *) a. WithAuthorizer' t m a -> m Authorizer
authorizer_} =
     WithAuthorizer' t m a
h { authorizer_ :: m Authorizer
authorizer_ = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>) m Authorizer
newV m Authorizer
authorizer_ }

-- | Wraps an existing handler block, attaching a 'Authorizer'. The handler has
-- to be a @ReaderT (Biscuit OpenOrSealed Verified)' to be able to access the token.
-- If you don't need to access the token from the handler block, you can use
-- 'withAuthorizer_' instead.
--
-- If you need to perform effects to compute the authorizer (eg. to get the current date,
-- or to query a database), you can use 'withAuthorizerM' instead.
withAuthorizer :: Applicative m
               => Authorizer
               -> ReaderT t m a
               -> WithAuthorizer' t m a
withAuthorizer :: forall (m :: * -> *) t a.
Applicative m =>
Authorizer -> ReaderT t m a -> WithAuthorizer' t m a
withAuthorizer Authorizer
v ReaderT t m a
handler_ =
  WithAuthorizer
    { ReaderT t m a
handler_ :: ReaderT t m a
handler_ :: ReaderT t m a
handler_
    , authorizer_ :: m Authorizer
authorizer_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Authorizer
v
    }

-- | Wraps an existing handler block, attaching a 'Authorizer'. The handler has
-- to be a @ReaderT (Biscuit OpenOrSealed Verified)@ to be able to access the token.
-- If you don't need to access the token from the handler block, you can use
-- 'withAuthorizer_' instead.
--
-- Here, the 'Authorizer' can be computed effectfully. If you don't need to perform effects,
-- you can use 'withAuthorizer' instead.
withAuthorizerM :: m Authorizer
                -> ReaderT t m a
                -> WithAuthorizer' t m a
withAuthorizerM :: forall (m :: * -> *) t a.
m Authorizer -> ReaderT t m a -> WithAuthorizer' t m a
withAuthorizerM m Authorizer
authorizer_ ReaderT t m a
handler_ =
  WithAuthorizer
    { ReaderT t m a
handler_ :: ReaderT t m a
handler_ :: ReaderT t m a
handler_
    , m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: m Authorizer
authorizer_
    }

-- | Wraps an existing handler block, attaching a 'Authorizer'. The handler can be
-- any monad, but won't be able to access the biscuit. If you want to read the biscuit
-- token from the handler block, you can use 'withAuthorizer' instead.
--
-- If you need to perform effects to compute the authorizer (eg. to get the current date,
-- or to query a database), you can use 'withAuthorizerM_' instead.
withAuthorizer_ :: Monad m => Authorizer -> m a -> WithAuthorizer' t m a
withAuthorizer_ :: forall (m :: * -> *) a t.
Monad m =>
Authorizer -> m a -> WithAuthorizer' t m a
withAuthorizer_ Authorizer
v = forall (m :: * -> *) t a.
Applicative m =>
Authorizer -> ReaderT t m a -> WithAuthorizer' t m a
withAuthorizer Authorizer
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Wraps an existing handler block, attaching a 'Authorizer'. The handler can be
-- any monad, but won't be able to access the 'Biscuit'.
--
-- If you want to read the biscuit token from the handler block, you can use 'withAuthorizer'
-- instead.
--
-- Here, the 'Authorizer' can be computed effectfully. If you don't need to perform effects,
-- you can use 'withAuthorizer_' instead.
withAuthorizerM_ :: Monad m => m Authorizer -> m a -> WithAuthorizer' t m a
withAuthorizerM_ :: forall (m :: * -> *) a t.
Monad m =>
m Authorizer -> m a -> WithAuthorizer' t m a
withAuthorizerM_ m Authorizer
v = forall (m :: * -> *) t a.
m Authorizer -> ReaderT t m a -> WithAuthorizer' t m a
withAuthorizerM m Authorizer
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Wraps an existing handler block, attaching an empty 'Authorizer'. The handler has
-- to be a @ReaderT (Biscuit OpenOrSealed Verified)@ to be able to access the token. If you don't need
-- to access the token from the handler block, you can use 'noAuthorizer_'
-- instead.
--
-- This function is useful when the endpoint does not have any specific authorizer
-- context, and the authorizer context is applied on the whole API tree through
-- 'withFallbackAuthorizer' or 'withPriorityAuthorizer' to apply policies on several
-- handlers at the same time (with 'hoistServer' for instance).
noAuthorizer :: Applicative m
           => ReaderT t m a
           -> WithAuthorizer' t m a
noAuthorizer :: forall (m :: * -> *) t a.
Applicative m =>
ReaderT t m a -> WithAuthorizer' t m a
noAuthorizer = forall (m :: * -> *) t a.
Applicative m =>
Authorizer -> ReaderT t m a -> WithAuthorizer' t m a
withAuthorizer forall a. Monoid a => a
mempty

-- | Wraps an existing handler block, attaching an empty 'Authorizer'. The handler can be
-- any monad, but won't be able to access the biscuit. If you want to read the
-- biscuit token from the handler block, you can use 'noAuthorizer' instead.
--
-- This function is useful when the endpoint does not have any specific authorizer
-- context, and the authorizer context is applied on the whole API tree through
-- 'withFallbackAuthorizer' or 'withPriorityAuthorizer' to apply policies on several
-- handlers at the same time (with 'hoistServer' for instance).
noAuthorizer_ :: Monad m => m a -> WithAuthorizer' t m a
noAuthorizer_ :: forall (m :: * -> *) a t. Monad m => m a -> WithAuthorizer' t m a
noAuthorizer_ = forall (m :: * -> *) t a.
Applicative m =>
ReaderT t m a -> WithAuthorizer' t m a
noAuthorizer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Configuration record for use with `authHandlerWith`. If you don't care about details,
-- you should use `authHandler` instead, which provides sensible defaults.
data BiscuitConfig e
  = BiscuitConfig
  { forall e. BiscuitConfig e -> ParserConfig Handler
parserConfig             :: ParserConfig Handler
  -- ^ how to parse a serialized biscuit (this includes public key and revocation checks)
  , forall e. BiscuitConfig e -> Request -> Either e ByteString
extractSerializedBiscuit :: Request -> Either e ByteString
  -- ^ how to extract the serialized biscuit from the request
  , forall e. BiscuitConfig e -> forall a. e -> Handler a
onExtractionError        :: forall a. e -> Handler a
  -- ^ what to do when the biscuit cannot be extracted from the request
  , forall e. BiscuitConfig e -> forall a. ParseError -> Handler a
onParseError             :: forall a. ParseError -> Handler a
  -- ^ what to do when the biscuit cannot be parsed
  }

-- | Default configuration used by `authHandler`.
--
-- It assumes:
--
-- - the biscuit is b64-encoded
-- - prefixed with the @Bearer @ string
-- - in the @Authorization@ header
--
-- It always uses the same public key and does not perform revocation checks. It returns
-- text-based 401 errors.
defaultBiscuitConfig :: PublicKey -> BiscuitConfig String
defaultBiscuitConfig :: PublicKey -> BiscuitConfig String
defaultBiscuitConfig PublicKey
publicKey = BiscuitConfig
  { parserConfig :: ParserConfig Handler
parserConfig = ParserConfig
      { getPublicKey :: Maybe Int -> PublicKey
getPublicKey = forall a b. a -> b -> a
const PublicKey
publicKey
      , isRevoked :: Set ByteString -> Handler Bool
isRevoked = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      , encoding :: BiscuitEncoding
encoding = BiscuitEncoding
UrlBase64
      }
  , extractSerializedBiscuit :: Request -> Either String ByteString
extractSerializedBiscuit = Request -> Either String ByteString
readFromAuthHeader
  , onExtractionError :: forall a. String -> Handler a
onExtractionError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ParseError String -> ServerError
defaultInvalidBiscuitError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
  , onParseError :: forall a. ParseError -> Handler a
onParseError      = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ParseError String -> ServerError
defaultInvalidBiscuitError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left
  }

-- | Read a serialized biscuit from the @Authorization@ header, assuming it is prefixed
-- by @Bearer@.
readFromAuthHeader :: Request -> Either String ByteString
readFromAuthHeader :: Request -> Either String ByteString
readFromAuthHeader Request
req = do
  let note :: a -> Maybe b -> Either a b
note a
e = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left a
e) forall a b. b -> Either a b
Right
  ByteString
authHeader <- forall {a} {b}. a -> Maybe b -> Either a b
note String
"Missing Authorization header" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Authorization" forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req
  forall {a} {b}. a -> Maybe b -> Either a b
note String
"Not a Bearer token" forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"Bearer " ByteString
authHeader

-- | Default 401 error returned if the biscuit can't be extracted or fails to parse.
defaultInvalidBiscuitError :: Either ParseError String -> ServerError
defaultInvalidBiscuitError :: Either ParseError String -> ServerError
defaultInvalidBiscuitError Either ParseError String
e =
  let s :: String
s = forall b a. b -> Either a b -> b
fromRight String
"Not a B64-encoded biscuit" Either ParseError String
e
   in ServerError
err401 { errBody :: ByteString
errBody = ByteString -> ByteString
LBS.fromStrict (String -> ByteString
C8.pack String
s) }

-- | Default 403 error returned if the biscuit fails authorization.
defaultUnauthorizedBiscuitError :: ExecutionError -> ServerError
defaultUnauthorizedBiscuitError :: ExecutionError -> ServerError
defaultUnauthorizedBiscuitError ExecutionError
_ =
  ServerError
err403 { errBody :: ByteString
errBody = ByteString
"Biscuit failed checks" }

-- | Servant authorization handler. This extracts the biscuit from the request,
-- checks its signature (but not the datalog part) and returns a 'Biscuit'
-- upon success. See `BiscuitConfig` for configuration details.
authHandlerWith :: BiscuitConfig e
                -> AuthHandler Request (Biscuit OpenOrSealed Verified)
authHandlerWith :: forall e.
BiscuitConfig e
-> AuthHandler Request (Biscuit OpenOrSealed Verified)
authHandlerWith BiscuitConfig{ParserConfig Handler
Request -> Either e ByteString
forall a. e -> Handler a
forall a. ParseError -> Handler a
onParseError :: forall a. ParseError -> Handler a
onExtractionError :: forall a. e -> Handler a
extractSerializedBiscuit :: Request -> Either e ByteString
parserConfig :: ParserConfig Handler
onParseError :: forall e. BiscuitConfig e -> forall a. ParseError -> Handler a
onExtractionError :: forall e. BiscuitConfig e -> forall a. e -> Handler a
extractSerializedBiscuit :: forall e. BiscuitConfig e -> Request -> Either e ByteString
parserConfig :: forall e. BiscuitConfig e -> ParserConfig Handler
..} = forall r usr. (r -> Handler usr) -> AuthHandler r usr
mkAuthHandler Request -> Handler (Biscuit OpenOrSealed Verified)
handler
  where
    orExtractionError :: Either e ByteString -> Handler ByteString
orExtractionError = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. e -> Handler a
onExtractionError  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    orParseError :: Either ParseError (Biscuit OpenOrSealed Verified)
-> Handler (Biscuit OpenOrSealed Verified)
orParseError = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. ParseError -> Handler a
onParseError forall (f :: * -> *) a. Applicative f => a -> f a
pure
    handler :: Request -> Handler (Biscuit OpenOrSealed Verified)
handler Request
req = do
      ByteString
bs <- Either e ByteString -> Handler ByteString
orExtractionError forall a b. (a -> b) -> a -> b
$ Request -> Either e ByteString
extractSerializedBiscuit Request
req
      Either ParseError (Biscuit OpenOrSealed Verified)
-> Handler (Biscuit OpenOrSealed Verified)
orParseError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
Applicative m =>
ParserConfig m
-> ByteString
-> m (Either ParseError (Biscuit OpenOrSealed Verified))
parseWith ParserConfig Handler
parserConfig ByteString
bs

-- | Default servant authorization handler. This extracts the biscuit from the request,
-- checks its signature (but not the datalog part) and returns a 'Biscuit'
-- upon success. If you need to customize token extraction or error handling, you can
-- use `authHandlerWith` instead.
authHandler :: PublicKey -> AuthHandler Request (Biscuit OpenOrSealed Verified)
authHandler :: PublicKey -> AuthHandler Request (Biscuit OpenOrSealed Verified)
authHandler = forall e.
BiscuitConfig e
-> AuthHandler Request (Biscuit OpenOrSealed Verified)
authHandlerWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> BiscuitConfig String
defaultBiscuitConfig

-- | Helper function generating a servant context containing the authorization
-- handler. The token will be read as a b64-url string (prefixed with @Bearer@)
-- in the @Authorization@ header.
--
-- If you need custom error handling or token parsing, you can use 'genBiscuitCtxWith'
-- instead.
genBiscuitCtx :: PublicKey
              -> Context '[AuthHandler Request (Biscuit OpenOrSealed Verified)]
genBiscuitCtx :: PublicKey
-> Context '[AuthHandler Request (Biscuit OpenOrSealed Verified)]
genBiscuitCtx PublicKey
pk = PublicKey -> AuthHandler Request (Biscuit OpenOrSealed Verified)
authHandler PublicKey
pk forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. Context '[]
EmptyContext

-- | Helper function generating a servant context containing the authorization
-- handler, with the provided configuration.
--
-- If you don't need custom error handling or token extraction, you can use
-- 'genBiscuitCtx' instead.
genBiscuitCtxWith :: BiscuitConfig e
                  -> Context '[AuthHandler Request (Biscuit OpenOrSealed Verified)]
genBiscuitCtxWith :: forall e.
BiscuitConfig e
-> Context '[AuthHandler Request (Biscuit OpenOrSealed Verified)]
genBiscuitCtxWith BiscuitConfig e
c = forall e.
BiscuitConfig e
-> AuthHandler Request (Biscuit OpenOrSealed Verified)
authHandlerWith BiscuitConfig e
c forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. Context '[]
EmptyContext

-- | Given a biscuit (provided by the servant authorization mechanism),
-- verify its validity (with the provided 'Authorizer').
--
-- If you need to perform effects in the verification phase (eg to get the current time,
-- or if you need to issue a DB query to retrieve extra information needed to check the token),
-- you can use 'checkBiscuitM' instead.
--
-- If you don't want to pass the biscuit manually to all the endpoints or want to
-- blanket apply authorizers on whole API trees, you can consider using 'withAuthorizer'
-- (on endpoints), 'withFallbackAuthorizer' and 'withPriorityAuthorizer' (on API sub-trees)
-- and 'handleBiscuit' (on the whole API).
checkBiscuit :: (MonadIO m, MonadError ServerError m)
             => Biscuit OpenOrSealed Verified
             -> Authorizer
             -> m a
             -> m a
checkBiscuit :: forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
Biscuit OpenOrSealed Verified -> Authorizer -> m a -> m a
checkBiscuit Biscuit OpenOrSealed Verified
vb = do
  forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
Biscuit OpenOrSealed Verified -> m Authorizer -> m a -> m a
checkBiscuitM Biscuit OpenOrSealed Verified
vb forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Given a biscuit (provided by the servant authorization mechanism),
-- verify its validity (with the provided 'Authorizer').
-- If the authorization fails, the provided error handler will be used to return
-- an error.
--
-- If you need to perform effects in the verification phase (eg to get the current time,
-- or if you need to issue a DB query to retrieve extra information needed to check the token),
-- you can use 'checkBiscuitMWith' instead.
--
-- If you don't want a custom error handler, you can use 'checkBiscuit' instead.
--
-- If you don't want to pass the biscuit manually to all the endpoints or want to
-- blanket apply authorizers on whole API trees, you can consider using 'withAuthorizer'
-- (on endpoints), 'withFallbackAuthorizer' and 'withPriorityAuthorizer' (on API sub-trees)
-- and 'handleBiscuit' (on the whole API).
checkBiscuitWith :: (MonadIO m, MonadError ServerError m)
                 => (forall b. ExecutionError -> m b)
                 -> Biscuit OpenOrSealed Verified
                 -> Authorizer
                 -> ReaderT (AuthorizedBiscuit OpenOrSealed) m a
                 -> m a
checkBiscuitWith :: forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
(forall b. ExecutionError -> m b)
-> Biscuit OpenOrSealed Verified
-> Authorizer
-> ReaderT (AuthorizedBiscuit OpenOrSealed) m a
-> m a
checkBiscuitWith forall b. ExecutionError -> m b
onError Biscuit OpenOrSealed Verified
vb =
  forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
(forall b. ExecutionError -> m b)
-> Biscuit OpenOrSealed Verified
-> m Authorizer
-> ReaderT (AuthorizedBiscuit OpenOrSealed) m a
-> m a
checkBiscuitMWith forall b. ExecutionError -> m b
onError Biscuit OpenOrSealed Verified
vb forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Given a 'Biscuit' (provided by the servant authorization mechanism),
-- verify its validity (with the provided 'Authorizer', which can be effectful).
--
-- If you don't need to run any effects in the verifying phase, you can use 'checkBiscuit'
-- instead.
--
-- If you don't want to pass the biscuit manually to all the endpoints or want to blanket apply
-- authorizers on whole API trees, you can consider using 'withAuthorizer' (on endpoints),
-- 'withFallbackAuthorizer' and 'withPriorityAuthorizer' (on API sub-trees) and 'handleBiscuit'
-- (on the whole API).
checkBiscuitM :: (MonadIO m, MonadError ServerError m)
              => Biscuit OpenOrSealed Verified
              -> m Authorizer
              -> m a
              -> m a
checkBiscuitM :: forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
Biscuit OpenOrSealed Verified -> m Authorizer -> m a -> m a
checkBiscuitM Biscuit OpenOrSealed Verified
vb m Authorizer
mv m a
h = do
  let onError :: ExecutionError -> m a
onError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExecutionError -> ServerError
defaultUnauthorizedBiscuitError
   in forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
(forall b. ExecutionError -> m b)
-> Biscuit OpenOrSealed Verified
-> m Authorizer
-> ReaderT (AuthorizedBiscuit OpenOrSealed) m a
-> m a
checkBiscuitMWith forall {a}. ExecutionError -> m a
onError Biscuit OpenOrSealed Verified
vb m Authorizer
mv (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
h)

-- | Given a 'Biscuit' (provided by the servant authorization mechanism),
-- verify its validity (with the provided 'Authorizer', which can be effectful).
-- If the authorization fails, the provided error handler will be used to return
-- an error.
--
-- If you don't need to run any effects in the verifying phase, you can use 'checkBiscuitWith'
-- instead.
--
-- If you don't want a custom error handler, you can use 'checkBiscuitM' instead.
--
-- If you don't want to pass the biscuit manually to all the endpoints or want to blanket apply
-- authorizers on whole API trees, you can consider using 'withAuthorizer' (on endpoints),
-- 'withFallbackAuthorizer' and 'withPriorityAuthorizer' (on API sub-trees) and 'handleBiscuit'
-- (on the whole API).
checkBiscuitMWith :: (MonadIO m, MonadError ServerError m)
                  => (forall b. ExecutionError -> m b)
                  -> Biscuit OpenOrSealed Verified
                  -> m Authorizer
                  -> ReaderT (AuthorizedBiscuit OpenOrSealed) m a
                  -> m a
checkBiscuitMWith :: forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
(forall b. ExecutionError -> m b)
-> Biscuit OpenOrSealed Verified
-> m Authorizer
-> ReaderT (AuthorizedBiscuit OpenOrSealed) m a
-> m a
checkBiscuitMWith forall b. ExecutionError -> m b
onError Biscuit OpenOrSealed Verified
vb m Authorizer
mv ReaderT (AuthorizedBiscuit OpenOrSealed) m a
h = do
  Authorizer
v   <- m Authorizer
mv
  Either ExecutionError (AuthorizedBiscuit OpenOrSealed)
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall proof.
Biscuit proof Verified
-> Authorizer
-> IO (Either ExecutionError (AuthorizedBiscuit proof))
authorizeBiscuit Biscuit OpenOrSealed Verified
vb Authorizer
v
  case Either ExecutionError (AuthorizedBiscuit OpenOrSealed)
res of
    Left ExecutionError
e   -> forall b. ExecutionError -> m b
onError ExecutionError
e
    Right AuthorizedBiscuit OpenOrSealed
as -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (AuthorizedBiscuit OpenOrSealed) m a
h AuthorizedBiscuit OpenOrSealed
as

-- | Given a handler wrapped in a 'WithAuthorizer', use the attached 'Authorizer' to
-- verify the provided biscuit and return an error as needed.
--
-- For simpler use cases, consider using 'checkBiscuit' instead, which works on regular
-- servant handlers.
handleBiscuit :: (MonadIO m, MonadError ServerError m)
              => Biscuit OpenOrSealed Verified
              -> WithAuthorizer m a
              -> m a
handleBiscuit :: forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
Biscuit OpenOrSealed Verified -> WithAuthorizer m a -> m a
handleBiscuit Biscuit OpenOrSealed Verified
b WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall t (m :: * -> *) a. WithAuthorizer' t m a -> m Authorizer
authorizer_, ReaderT (AuthorizedBiscuit OpenOrSealed) m a
handler_ :: ReaderT (AuthorizedBiscuit OpenOrSealed) m a
handler_ :: forall t (m :: * -> *) a. WithAuthorizer' t m a -> ReaderT t m a
handler_} =
  let onError :: ExecutionError -> m a
onError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExecutionError -> ServerError
defaultUnauthorizedBiscuitError
   in forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
(forall b. ExecutionError -> m b)
-> Biscuit OpenOrSealed Verified
-> m Authorizer
-> ReaderT (AuthorizedBiscuit OpenOrSealed) m a
-> m a
checkBiscuitMWith forall {a}. ExecutionError -> m a
onError Biscuit OpenOrSealed Verified
b m Authorizer
authorizer_ ReaderT (AuthorizedBiscuit OpenOrSealed) m a
handler_

-- | Given a handler wrapped in a 'WithAuthorizer', use the attached 'Authorizer' to
-- verify the provided biscuit and return an error as needed, with the provided error
-- handler.
--
-- If you don't want to provide the error handler, you can use 'handleBiscuit' which
-- uses a default error handler
--
-- For simpler use cases, consider using 'checkBiscuitWith' instead, which works on regular
-- servant handlers.
handleBiscuitWith :: (MonadIO m, MonadError ServerError m)
                  => (forall b. ExecutionError -> m b)
                  -> Biscuit OpenOrSealed Verified
                  -> WithAuthorizer m a
                  -> m a
handleBiscuitWith :: forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
(forall b. ExecutionError -> m b)
-> Biscuit OpenOrSealed Verified -> WithAuthorizer m a -> m a
handleBiscuitWith forall b. ExecutionError -> m b
onError Biscuit OpenOrSealed Verified
b WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall t (m :: * -> *) a. WithAuthorizer' t m a -> m Authorizer
authorizer_, ReaderT (AuthorizedBiscuit OpenOrSealed) m a
handler_ :: ReaderT (AuthorizedBiscuit OpenOrSealed) m a
handler_ :: forall t (m :: * -> *) a. WithAuthorizer' t m a -> ReaderT t m a
handler_} =
  forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
(forall b. ExecutionError -> m b)
-> Biscuit OpenOrSealed Verified
-> m Authorizer
-> ReaderT (AuthorizedBiscuit OpenOrSealed) m a
-> m a
checkBiscuitMWith forall b. ExecutionError -> m b
onError Biscuit OpenOrSealed Verified
b m Authorizer
authorizer_ ReaderT (AuthorizedBiscuit OpenOrSealed) m a
handler_

-- | Transform the context provided by 'WithAuthorizer'' in an effectful way.
-- This is useful to turn an 'AuthorizedBiscuit' into a custom type.
-- Transformations can be chained within an API tree as long as the outermost value
-- is a 'WithAuthorizer', that can be handled by 'handleBiscuit'.
withTransformation :: Monad m
                   => (t -> m t')
                   -- ^ context transformation function. @t@ will usually be
                   -- @AuthorizedBiscuit OpenOrSealed@
                   -> WithAuthorizer' t' m a
                   -- ^ wrapped handler with reader access to a @t'@ value
                   -- (derived from an @AuthorizedBiscuit OpenOrSealed@)
                   -> WithAuthorizer' t  m a
                   -- ^ wrapped handler with reader access to a @t@ value
                   -- (usually @AuthorizedBiscuit OpenOrSealed@)
withTransformation :: forall (m :: * -> *) t t' a.
Monad m =>
(t -> m t') -> WithAuthorizer' t' m a -> WithAuthorizer' t m a
withTransformation t -> m t'
compute wa :: WithAuthorizer' t' m a
wa@WithAuthorizer{ReaderT t' m a
handler_ :: ReaderT t' m a
handler_ :: forall t (m :: * -> *) a. WithAuthorizer' t m a -> ReaderT t m a
handler_} =
  let newHandler :: ReaderT t m a
newHandler = do
        t'
t' <- forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT t -> m t'
compute
        forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (forall a b. a -> b -> a
const t'
t') ReaderT t' m a
handler_
   in WithAuthorizer' t' m a
wa { handler_ :: ReaderT t m a
handler_ = ReaderT t m a
newHandler }