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

  -- ** Annotating servant API types
  -- $apitypes
    RequireBiscuit
  , authHandler
  , genBiscuitCtx
  -- ** Supplying a authorizer for a single endpoint
  -- $singleEndpointAuthorizer
  , checkBiscuit
  , checkBiscuitM
  -- ** Decorate regular handlers with composable authorizers
  -- $composableAuthorizers
  , WithAuthorizer (..)
  , handleBiscuit
  , withAuthorizer
  , withAuthorizer_
  , withAuthorizerM
  , withAuthorizerM_
  , noAuthorizer
  , noAuthorizer_
  , withFallbackAuthorizer
  , withPriorityAuthorizer
  , withFallbackAuthorizerM
  , withPriorityAuthorizerM

  , module Biscuit
  ) where

import           Auth.Biscuit                     as Biscuit
import           Data.Kind (Type)
import           Control.Applicative              (liftA2)
import           Control.Monad.Except             (MonadError, throwError)
import           Control.Monad.IO.Class           (MonadIO, liftIO)
import           Control.Monad.Reader             (ReaderT, lift, runReaderT)
import           Data.Bifunctor                   (first)
import qualified Data.ByteString                  as BS
import qualified Data.ByteString.Char8            as C8
import qualified Data.ByteString.Lazy             as LBS
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 and 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
-- >
-- > 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 show 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|allow if right("three");|]
-- >   (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.

-- | Type used to protect and 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"
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 verified biscuit through
-- a @ReaderT (Biscuit OpenOrSealed Verified)@.
data WithAuthorizer (m :: Type -> Type) (a :: Type)
  = WithAuthorizer
  { WithAuthorizer m a -> ReaderT (Biscuit OpenOrSealed Verified) m a
handler_    :: ReaderT (Biscuit OpenOrSealed Verified) m a
  -- ^ the wrapped handler, in a 'ReaderT' to give easy access to the biscuit
  , WithAuthorizer m a -> m Authorizer
authorizer_ :: m Authorizer
  -- ^ the 'Authorizer' associated to the handler
  }

-- | 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 m a
                     -> WithAuthorizer m a
withFallbackAuthorizer :: Authorizer -> WithAuthorizer m a -> WithAuthorizer m a
withFallbackAuthorizer Authorizer
newV h :: WithAuthorizer m a
h@WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall (m :: * -> *) a. WithAuthorizer m a -> m Authorizer
authorizer_} =
  WithAuthorizer m a
h { authorizer_ :: m Authorizer
authorizer_ = (Authorizer -> Authorizer -> Authorizer
forall a. Semigroup a => a -> a -> a
<> Authorizer
newV) (Authorizer -> Authorizer) -> m Authorizer -> m Authorizer
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 m a
                      -> WithAuthorizer m a
withFallbackAuthorizerM :: m Authorizer -> WithAuthorizer m a -> WithAuthorizer m a
withFallbackAuthorizerM m Authorizer
newV h :: WithAuthorizer m a
h@WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall (m :: * -> *) a. WithAuthorizer m a -> m Authorizer
authorizer_} =
  WithAuthorizer m a
h { authorizer_ :: m Authorizer
authorizer_ = (Authorizer -> Authorizer -> Authorizer)
-> m Authorizer -> m Authorizer -> m Authorizer
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Authorizer -> Authorizer -> Authorizer
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 :: Authorizer -> WithAuthorizer m a -> WithAuthorizer m a
withPriorityAuthorizer Authorizer
newV h :: WithAuthorizer m a
h@WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall (m :: * -> *) a. WithAuthorizer m a -> m Authorizer
authorizer_} =
     WithAuthorizer m a
h { authorizer_ :: m Authorizer
authorizer_ = (Authorizer
newV Authorizer -> Authorizer -> Authorizer
forall a. Semigroup a => a -> a -> a
<>) (Authorizer -> Authorizer) -> m Authorizer -> m Authorizer
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 m a
                      -> WithAuthorizer m a
withPriorityAuthorizerM :: m Authorizer -> WithAuthorizer m a -> WithAuthorizer m a
withPriorityAuthorizerM m Authorizer
newV h :: WithAuthorizer m a
h@WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall (m :: * -> *) a. WithAuthorizer m a -> m Authorizer
authorizer_} =
     WithAuthorizer m a
h { authorizer_ :: m Authorizer
authorizer_ = (Authorizer -> Authorizer -> Authorizer)
-> m Authorizer -> m Authorizer -> m Authorizer
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Authorizer -> Authorizer -> Authorizer
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 (Biscuit OpenOrSealed Verified) m a
             -> WithAuthorizer m a
withAuthorizer :: Authorizer
-> ReaderT (Biscuit OpenOrSealed Verified) m a
-> WithAuthorizer m a
withAuthorizer Authorizer
v ReaderT (Biscuit OpenOrSealed Verified) m a
handler_ =
  WithAuthorizer :: forall (m :: * -> *) a.
ReaderT (Biscuit OpenOrSealed Verified) m a
-> m Authorizer -> WithAuthorizer m a
WithAuthorizer
    { ReaderT (Biscuit OpenOrSealed Verified) m a
handler_ :: ReaderT (Biscuit OpenOrSealed Verified) m a
handler_ :: ReaderT (Biscuit OpenOrSealed Verified) m a
handler_
    , authorizer_ :: m Authorizer
authorizer_ = Authorizer -> m 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 (Biscuit OpenOrSealed Verified) m a
              -> WithAuthorizer m a
withAuthorizerM :: m Authorizer
-> ReaderT (Biscuit OpenOrSealed Verified) m a
-> WithAuthorizer m a
withAuthorizerM m Authorizer
authorizer_ ReaderT (Biscuit OpenOrSealed Verified) m a
handler_ =
  WithAuthorizer :: forall (m :: * -> *) a.
ReaderT (Biscuit OpenOrSealed Verified) m a
-> m Authorizer -> WithAuthorizer m a
WithAuthorizer
    { ReaderT (Biscuit OpenOrSealed Verified) m a
handler_ :: ReaderT (Biscuit OpenOrSealed Verified) m a
handler_ :: ReaderT (Biscuit OpenOrSealed Verified) 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 m a
withAuthorizer_ :: Authorizer -> m a -> WithAuthorizer m a
withAuthorizer_ Authorizer
v = Authorizer
-> ReaderT (Biscuit OpenOrSealed Verified) m a
-> WithAuthorizer m a
forall (m :: * -> *) a.
Applicative m =>
Authorizer
-> ReaderT (Biscuit OpenOrSealed Verified) m a
-> WithAuthorizer m a
withAuthorizer Authorizer
v (ReaderT (Biscuit OpenOrSealed Verified) m a -> WithAuthorizer m a)
-> (m a -> ReaderT (Biscuit OpenOrSealed Verified) m a)
-> m a
-> WithAuthorizer m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (Biscuit OpenOrSealed Verified) m a
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 m a
withAuthorizerM_ :: m Authorizer -> m a -> WithAuthorizer m a
withAuthorizerM_ m Authorizer
v = m Authorizer
-> ReaderT (Biscuit OpenOrSealed Verified) m a
-> WithAuthorizer m a
forall (m :: * -> *) a.
m Authorizer
-> ReaderT (Biscuit OpenOrSealed Verified) m a
-> WithAuthorizer m a
withAuthorizerM m Authorizer
v (ReaderT (Biscuit OpenOrSealed Verified) m a -> WithAuthorizer m a)
-> (m a -> ReaderT (Biscuit OpenOrSealed Verified) m a)
-> m a
-> WithAuthorizer m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (Biscuit OpenOrSealed Verified) m a
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 (Biscuit OpenOrSealed Verified) m a
           -> WithAuthorizer m a
noAuthorizer :: ReaderT (Biscuit OpenOrSealed Verified) m a -> WithAuthorizer m a
noAuthorizer = Authorizer
-> ReaderT (Biscuit OpenOrSealed Verified) m a
-> WithAuthorizer m a
forall (m :: * -> *) a.
Applicative m =>
Authorizer
-> ReaderT (Biscuit OpenOrSealed Verified) m a
-> WithAuthorizer m a
withAuthorizer Authorizer
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 m a
noAuthorizer_ :: m a -> WithAuthorizer m a
noAuthorizer_ = ReaderT (Biscuit OpenOrSealed Verified) m a -> WithAuthorizer m a
forall (m :: * -> *) a.
Applicative m =>
ReaderT (Biscuit OpenOrSealed Verified) m a -> WithAuthorizer m a
noAuthorizer (ReaderT (Biscuit OpenOrSealed Verified) m a -> WithAuthorizer m a)
-> (m a -> ReaderT (Biscuit OpenOrSealed Verified) m a)
-> m a
-> WithAuthorizer m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (Biscuit OpenOrSealed Verified) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Extracts a biscuit from an http request, assuming:
--
-- - the biscuit is b64-encoded
-- - prefixed with the @Bearer @ string
-- - in the @Authorization@ header
extractBiscuit :: PublicKey
               -> Request
               -> Either String (Biscuit OpenOrSealed Verified)
extractBiscuit :: PublicKey
-> Request -> Either String (Biscuit OpenOrSealed Verified)
extractBiscuit PublicKey
pk Request
req = do
  let note :: a -> Maybe b -> Either a b
note a
e = Either a b -> (b -> Either a b) -> Maybe b -> Either a b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Either a b
forall a b. a -> Either a b
Left a
e) b -> Either a b
forall a b. b -> Either a b
Right
  ByteString
authHeader <- String -> Maybe ByteString -> Either String ByteString
forall a b. a -> Maybe b -> Either a b
note String
"Missing Authorization header" (Maybe ByteString -> Either String ByteString)
-> ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)]
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Authorization" ([(HeaderName, ByteString)] -> Either String ByteString)
-> [(HeaderName, ByteString)] -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
  ByteString
b64Token   <- String -> Maybe ByteString -> Either String ByteString
forall a b. a -> Maybe b -> Either a b
note String
"Not a Bearer token" (Maybe ByteString -> Either String ByteString)
-> Maybe ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"Bearer " ByteString
authHeader
  (ParseError -> String)
-> Either ParseError (Biscuit OpenOrSealed Verified)
-> Either String (Biscuit OpenOrSealed Verified)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> ParseError -> String
forall a b. a -> b -> a
const String
"Not a B64-encoded biscuit") (Either ParseError (Biscuit OpenOrSealed Verified)
 -> Either String (Biscuit OpenOrSealed Verified))
-> Either ParseError (Biscuit OpenOrSealed Verified)
-> Either String (Biscuit OpenOrSealed Verified)
forall a b. (a -> b) -> a -> b
$ PublicKey
-> ByteString -> Either ParseError (Biscuit OpenOrSealed Verified)
parseB64 PublicKey
pk ByteString
b64Token

-- | Servant authorization handler. This extracts the biscuit from the request,
-- checks its signature (but not the datalog part) and returns a 'Biscuit'
-- upon success.
authHandler :: PublicKey
            -> AuthHandler Request (Biscuit OpenOrSealed Verified)
authHandler :: PublicKey -> AuthHandler Request (Biscuit OpenOrSealed Verified)
authHandler PublicKey
publicKey = (Request -> Handler (Biscuit OpenOrSealed Verified))
-> AuthHandler Request (Biscuit OpenOrSealed Verified)
forall r usr. (r -> Handler usr) -> AuthHandler r usr
mkAuthHandler Request -> Handler (Biscuit OpenOrSealed Verified)
handler
  where
    authError :: String -> ServerError
authError String
s = ServerError
err401 { errBody :: ByteString
errBody = ByteString -> ByteString
LBS.fromStrict (String -> ByteString
C8.pack String
s) }
    orError :: Either String a -> Handler a
orError = (String -> Handler a)
-> (a -> Handler a) -> Either String a -> Handler a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> Handler a)
-> (String -> ServerError) -> String -> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ServerError
authError) a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    handler :: Request -> Handler (Biscuit OpenOrSealed Verified)
handler Request
req =
      Either String (Biscuit OpenOrSealed Verified)
-> Handler (Biscuit OpenOrSealed Verified)
forall a. Either String a -> Handler a
orError (Either String (Biscuit OpenOrSealed Verified)
 -> Handler (Biscuit OpenOrSealed Verified))
-> Either String (Biscuit OpenOrSealed Verified)
-> Handler (Biscuit OpenOrSealed Verified)
forall a b. (a -> b) -> a -> b
$ PublicKey
-> Request -> Either String (Biscuit OpenOrSealed Verified)
extractBiscuit PublicKey
publicKey Request
req

-- | Helper function generating a servant context containing the authorization
-- handler.
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 AuthHandler Request (Biscuit OpenOrSealed Verified)
-> Context '[]
-> Context '[AuthHandler Request (Biscuit OpenOrSealed Verified)]
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 :: Biscuit OpenOrSealed Verified -> Authorizer -> m a -> m a
checkBiscuit Biscuit OpenOrSealed Verified
vb Authorizer
v m a
h = do
  Either ExecutionError AuthorizationSuccess
res <- IO (Either ExecutionError AuthorizationSuccess)
-> m (Either ExecutionError AuthorizationSuccess)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ExecutionError AuthorizationSuccess)
 -> m (Either ExecutionError AuthorizationSuccess))
-> IO (Either ExecutionError AuthorizationSuccess)
-> m (Either ExecutionError AuthorizationSuccess)
forall a b. (a -> b) -> a -> b
$ Biscuit OpenOrSealed Verified
-> Authorizer -> IO (Either ExecutionError AuthorizationSuccess)
forall proof.
Biscuit proof Verified
-> Authorizer -> IO (Either ExecutionError AuthorizationSuccess)
authorizeBiscuit Biscuit OpenOrSealed Verified
vb Authorizer
v
  case Either ExecutionError AuthorizationSuccess
res of
    Left ExecutionError
e  -> do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ExecutionError -> IO ()
forall a. Show a => a -> IO ()
print ExecutionError
e
                  ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> m a) -> ServerError -> m a
forall a b. (a -> b) -> a -> b
$ ServerError
err401 { errBody :: ByteString
errBody = ByteString
"Biscuit failed checks" }
    Right AuthorizationSuccess
_ -> m a
h

-- | 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 :: Biscuit OpenOrSealed Verified -> m Authorizer -> m a -> m a
checkBiscuitM Biscuit OpenOrSealed Verified
vb m Authorizer
mv m a
h = do
  Authorizer
v   <- m Authorizer
mv
  Either ExecutionError AuthorizationSuccess
res <- IO (Either ExecutionError AuthorizationSuccess)
-> m (Either ExecutionError AuthorizationSuccess)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ExecutionError AuthorizationSuccess)
 -> m (Either ExecutionError AuthorizationSuccess))
-> IO (Either ExecutionError AuthorizationSuccess)
-> m (Either ExecutionError AuthorizationSuccess)
forall a b. (a -> b) -> a -> b
$ Biscuit OpenOrSealed Verified
-> Authorizer -> IO (Either ExecutionError AuthorizationSuccess)
forall proof.
Biscuit proof Verified
-> Authorizer -> IO (Either ExecutionError AuthorizationSuccess)
authorizeBiscuit Biscuit OpenOrSealed Verified
vb Authorizer
v
  case Either ExecutionError AuthorizationSuccess
res of
    Left ExecutionError
e  -> do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ExecutionError -> IO ()
forall a. Show a => a -> IO ()
print ExecutionError
e
                  ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> m a) -> ServerError -> m a
forall a b. (a -> b) -> a -> b
$ ServerError
err401 { errBody :: ByteString
errBody = ByteString
"Biscuit failed checks" }
    Right AuthorizationSuccess
_ -> m a
h

-- | 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 :: Biscuit OpenOrSealed Verified -> WithAuthorizer m a -> m a
handleBiscuit Biscuit OpenOrSealed Verified
b WithAuthorizer{m Authorizer
authorizer_ :: m Authorizer
authorizer_ :: forall (m :: * -> *) a. WithAuthorizer m a -> m Authorizer
authorizer_, ReaderT (Biscuit OpenOrSealed Verified) m a
handler_ :: ReaderT (Biscuit OpenOrSealed Verified) m a
handler_ :: forall (m :: * -> *) a.
WithAuthorizer m a -> ReaderT (Biscuit OpenOrSealed Verified) m a
handler_} =
  let h :: m a
h = ReaderT (Biscuit OpenOrSealed Verified) m a
-> Biscuit OpenOrSealed Verified -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Biscuit OpenOrSealed Verified) m a
handler_ Biscuit OpenOrSealed Verified
b
  in Biscuit OpenOrSealed Verified -> m Authorizer -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadError ServerError m) =>
Biscuit OpenOrSealed Verified -> m Authorizer -> m a -> m a
checkBiscuitM Biscuit OpenOrSealed Verified
b m Authorizer
authorizer_ m a
h