{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK prune #-}

{- |
Support integrating web services created by __servant__ with handlers defined
in the 'Program' monad. This is a thin wrapper which creates an 'Application'
which can be used with 'Core.Webserver.Warp.launchWebserver'.

@
import "Core.Program"
import "Core.Webserver.Servant"
import "Core.Webserver.Warp"

import MyServer (api, routes)

main :: 'IO' ()
main = do
    'Core.Program.Execute.execute' $ do
        application <- 'prepareRoutes' api routes
        'launchWebserver' 8080 application
@
-}
module Core.Webserver.Servant (
    prepareRoutes,
    prepareRoutesWithContext,
) where

import Control.Monad.Except (ExceptT (..))
import Core.Program
import Core.System (Exception (..))
import Core.Telemetry.Observability (clearMetrics)
import Core.Webserver.Warp
import Data.Proxy (Proxy)
import GHC.Base (Type)
import Network.Wai (Application)
import qualified Servant as Servant (
    Handler (..),
    ServerT,
 )
import qualified Servant.Server 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."

{- |
Convert a __servant__ API and set of handlers into a __warp__ 'Application'.

This 'Application' must be used with 'Core.Webserver.Warp.launchWebserver' so
that the necessary internal connections are made.

Usage is straight forward:

@
        application <- 'prepareRoutes' api routes
        'launchWebserver' 8080 application
@

This code creates an Application which has sufficient information to unlift
back to the 'Program' monad so that your handlers can be take advantage of the
logging and telemetry facilities of __core-program__ and __core-telemetry__.
-}
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

{- |
Prepare routes as with 'prepareRoutes' above, but providing a __servant__
'Servant.Server.Context' in order to give detailed control of the setup.

@since 0.1.1
-}
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
        -- The type application in `contextFromRequest` is important, as
        -- otherwise the compiler cannot infer that the type of
        -- `transformProgram` is of the same `τ` as the one in `Program τ`

        -- This exception will happen in the case where this is not being run
        -- by `launchWebserver`, since we need the Context to be stashed in
        -- the request by the Middleware there.

        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
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)
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 τ ()
forall τ. Program τ ()
clearMetrics
                        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)