{-# 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,
)
data ContextNotFoundInRequest = ContextNotFoundInRequest deriving (Int -> ContextNotFoundInRequest -> ShowS
[ContextNotFoundInRequest] -> ShowS
ContextNotFoundInRequest -> String
(Int -> ContextNotFoundInRequest -> ShowS)
-> (ContextNotFoundInRequest -> String)
-> ([ContextNotFoundInRequest] -> ShowS)
-> Show ContextNotFoundInRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContextNotFoundInRequest] -> ShowS
$cshowList :: [ContextNotFoundInRequest] -> ShowS
show :: ContextNotFoundInRequest -> String
$cshow :: ContextNotFoundInRequest -> String
showsPrec :: Int -> ContextNotFoundInRequest -> ShowS
$cshowsPrec :: Int -> ContextNotFoundInRequest -> ShowS
Show)
instance Exception ContextNotFoundInRequest where
displayException :: ContextNotFoundInRequest -> String
displayException ContextNotFoundInRequest
_ = String
"Context was not found in request. This is a serious error."
prepareRoutes ::
forall τ (api :: Type).
Servant.HasServer api '[] =>
Proxy api ->
Servant.ServerT api (Program τ) ->
Program τ Application
prepareRoutes :: Proxy api -> ServerT api (Program τ) -> Program τ Application
prepareRoutes Proxy api
proxy = Proxy api
-> Context '[] -> ServerT api (Program τ) -> Program τ Application
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 :: Proxy api
-> Context context
-> ServerT api (Program τ)
-> Program τ Application
prepareRoutesWithContext Proxy api
proxy Context context
sContext (ServerT api (Program τ)
routes :: Servant.ServerT api (Program τ)) =
Application -> Program τ Application
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 Request -> Maybe (Context τ)
forall t. Request -> Maybe (Context t)
contextFromRequest @τ Request
request of
Just Context τ
context' -> Context τ -> IO (Context τ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context τ
context'
Maybe (Context τ)
Nothing -> ContextNotFoundInRequest -> IO (Context τ)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw ContextNotFoundInRequest
ContextNotFoundInRequest
Proxy api
-> Context context
-> (forall x. Program τ x -> Handler x)
-> ServerT api (Program τ)
-> Application
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
(Context τ -> Program τ x -> Handler x
forall α. Context τ -> Program τ α -> Handler α
transformProgram Context τ
context)
ServerT api (Program τ)
routes
Request
request
Response -> IO ResponseReceived
sendResponse
transformProgram :: Context τ -> Program τ α -> Servant.Handler α
transformProgram :: Context τ -> Program τ α -> Handler α
transformProgram Context τ
context Program τ α
program =
let output :: IO (Either ServerError α)
output =
IO α -> IO (Either ServerError α)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Safe.try (IO α -> IO (Either ServerError α))
-> IO α -> IO (Either ServerError α)
forall a b. (a -> b) -> a -> b
$
Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context (Program τ α -> IO α) -> Program τ α -> IO α
forall a b. (a -> b) -> a -> b
$ do
Program τ α
program
in ExceptT ServerError IO α -> Handler α
forall a. ExceptT ServerError IO a -> Handler a
Servant.Handler (IO (Either ServerError α) -> ExceptT ServerError IO α
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT IO (Either ServerError α)
output)