Native.hs

-- | Description: Server runners using 'Jwt' for authentication
module Polysemy.Account.Api.Native where

import Servant (
  Context (EmptyContext, (:.)),
  DefaultErrorFormatters,
  ErrorFormatters,
  HasContextEntry,
  HasServer,
  ServerError,
  ServerT,
  type (.++),
  )
import Servant.Auth.Server (CookieSettings, JWTSettings, defaultCookieSettings)

import qualified Polysemy.Account.Api.Effect.Jwt as Jwt
import Polysemy.Account.Api.Effect.Jwt (Jwt)
import Polysemy.Account.Api.NativeContext (ServerReady, runServer)
import Polysemy.Account.Data.Port (Port)

-- | The Servant context for 'Jwt' servers.
type AuthContext =
  [JWTSettings, CookieSettings]

-- | Servant constraint for servers using JWT.
type ServerAuth api =
  HasServer api AuthContext

-- | Run a Servant server with JSON Web Token authentication using settings from 'Jwt'.
--
-- This variant allows supplying additional 'Context's.
runServerJwtWith ::
  ∀ (api :: Type) (context :: [Type]) a e r .
  HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters =>
  HasServer api (AuthContext ++ context) =>
  Members [Sync ServerReady, Jwt a !! e, Log, Interrupt, Error Text, Final IO] r =>
  Context context ->
  ServerT api (Sem (Stop ServerError : r)) ->
  Port ->
  Sem r ()
runServerJwtWith ctx srv port = do
  jwtSettings <- Jwt.settings !>> throw "Jwt initialization failed"
  runServer @api srv (jwtSettings :. defaultCookieSettings :. ctx) port

-- | Run a Servant server with JSON Web Token authentication using settings from 'Jwt'.
runServerJwt ::
  ∀ (api :: Type) a e r .
  ServerAuth api =>
  Members [Sync ServerReady, Jwt a !! e, Log, Interrupt, Error Text, Final IO] r =>
  ServerT api (Sem (Stop ServerError : r)) ->
  Port ->
  Sem r ()
runServerJwt =
  runServerJwtWith @api EmptyContext