{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Webserver.Servant (
prepareRoutes,
prepareRoutesWithContext,
) where
import Control.Exception.Safe qualified as Safe (try, throw)
import Control.Monad.Except (ExceptT (..))
import Core.Program
import Core.System (Exception (..))
import Core.Webserver.Warp
import Data.Proxy (Proxy)
import GHC.Base (Type)
import Network.Wai (Application)
import Servant qualified as Servant (
Handler (..),
ServerT,
)
import Servant.Server qualified as Servant (
Context (..),
HasServer,
ServerContext,
serveWithContextT,
)
prepareRoutes ::
forall τ (api :: Type).
Servant.HasServer api '[] =>
Proxy api ->
Servant.ServerT api (Program τ) ->
Program τ Application
prepareRoutes :: forall τ api.
HasServer api '[] =>
Proxy api -> ServerT api (Program τ) -> Program τ Application
prepareRoutes Proxy api
proxy = forall τ api (context :: [*]).
(HasServer api context, ServerContext context) =>
Proxy api
-> Context context
-> ServerT api (Program τ)
-> Program τ Application
prepareRoutesWithContext Proxy api
proxy Context '[]
Servant.EmptyContext
prepareRoutesWithContext ::
forall τ (api :: Type) context.
(Servant.HasServer api context, Servant.ServerContext context) =>
Proxy api ->
Servant.Context context ->
Servant.ServerT api (Program τ) ->
Program τ Application
prepareRoutesWithContext :: forall τ api (context :: [*]).
(HasServer api context, ServerContext context) =>
Proxy api
-> Context context
-> ServerT api (Program τ)
-> Program τ Application
prepareRoutesWithContext Proxy api
proxy Context context
sContext (ServerT api (Program τ)
routes :: Servant.ServerT api (Program τ)) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Application
application
where
application :: Application
application :: Application
application = \Request
request Response -> IO ResponseReceived
sendResponse -> do
Context τ
context <- case forall t. Request -> Maybe (Context t)
contextFromRequest @τ Request
request of
Just Context τ
context' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Context τ
context'
Maybe (Context τ)
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw ContextNotFoundInRequest
ContextNotFoundInRequest
forall api (context :: [*]) (m :: * -> *).
(HasServer api context, ServerContext context) =>
Proxy api
-> Context context
-> (forall x. m x -> Handler x)
-> ServerT api m
-> Application
Servant.serveWithContextT
Proxy api
proxy
Context context
sContext
(forall α. Context τ -> Program τ α -> Handler α
transformProgram Context τ
context)
ServerT api (Program τ)
routes
Request
request
Response -> IO ResponseReceived
sendResponse
transformProgram :: Context τ -> Program τ α -> Servant.Handler α
transformProgram :: forall α. Context τ -> Program τ α -> Handler α
transformProgram Context τ
context Program τ α
program =
let output :: IO (Either ServerError α)
output =
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Safe.try forall a b. (a -> b) -> a -> b
$
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context forall a b. (a -> b) -> a -> b
$ do
Program τ α
program
in forall a. ExceptT ServerError IO a -> Handler a
Servant.Handler (forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT IO (Either ServerError α)
output)