{-# options_haddock prune #-}

-- | Description: Full Polysemy runners for Servant servers
module Polysemy.Account.Api.NativeContext where

import Control.Monad.Trans.Except (ExceptT (ExceptT))
import Exon.Quote (exon)
import qualified Log
import Network.Wai (Application)
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Handler.Warp (
  defaultSettings,
  setBeforeMainLoop,
  setGracefulShutdownTimeout,
  setHost,
  setInstallShutdownHandler,
  setPort,
  )
import qualified Network.Wai.Middleware.RequestLogger as Logger
import Network.Wai.Middleware.RequestLogger (destination, mkRequestLogger)
import qualified Polysemy.Conc.Effect.Interrupt as Interrupt
import Polysemy.Final (withWeavingToFinal)
import Servant (
  Context,
  DefaultErrorFormatters,
  ErrorFormatters,
  Handler (Handler),
  HasContextEntry,
  HasServer,
  Server,
  ServerError,
  ServerT,
  err500,
  hoistServerWithContext,
  serveWithContext,
  type (.++),
  )
import qualified Sync
import System.Log.FastLogger (fromLogStr)

import Polysemy.Account.Data.Port (Port (Port))

-- | A dummy value used to indicate that the server has fully started up, using 'Sync'.
data ServerReady = ServerReady
  deriving stock (ServerReady -> ServerReady -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ServerReady -> ServerReady -> Bool
$c/= :: ServerReady -> ServerReady -> Bool
== :: ServerReady -> ServerReady -> Bool
$c== :: ServerReady -> ServerReady -> Bool
Eq, Int -> ServerReady -> ShowS
[ServerReady] -> ShowS
ServerReady -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerReady] -> ShowS
$cshowList :: [ServerReady] -> ShowS
show :: ServerReady -> String
$cshow :: ServerReady -> String
showsPrec :: Int -> ServerReady -> ShowS
$cshowsPrec :: Int -> ServerReady -> ShowS
Show)

logErrors ::
  Member Log r =>
  Sem r (Either ServerError a) ->
  Sem r (Either ServerError a)
logErrors :: forall (r :: EffectRow) a.
Member Log r =>
Sem r (Either ServerError a) -> Sem r (Either ServerError a)
logErrors Sem r (Either ServerError a)
ma =
  Sem r (Either ServerError a)
ma forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right a
a)
    Left ServerError
err -> forall a b. a -> Either a b
Left ServerError
err forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.error (forall b a. (Show a, IsString b) => a -> b
show ServerError
err)

lowerServer ::
  ∀ (api :: Type) context r s .
  Functor s =>
  Member Log r =>
  HasServer api context =>
  s () ->
  (∀ a . s (Sem r a) -> IO (s a)) ->
  (∀ x . s x -> Maybe x) ->
  ServerT api (Sem (Stop ServerError : r)) ->
  Server api
lowerServer :: forall api (context :: [*]) (r :: EffectRow) (s :: * -> *).
(Functor s, Member Log r, HasServer api context) =>
s ()
-> (forall a. s (Sem r a) -> IO (s a))
-> (forall x. s x -> Maybe x)
-> ServerT api (Sem (Stop ServerError : r))
-> Server api
lowerServer s ()
s forall a. s (Sem r a) -> IO (s a)
lower forall x. s x -> Maybe x
ins ServerT api (Sem (Stop ServerError : r))
srv =
  forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy @api) (forall {k} (t :: k). Proxy t
Proxy @context) forall x. Sem (Stop ServerError : r) x -> Handler x
handle ServerT api (Sem (Stop ServerError : r))
srv
  where
    handleErrors :: Sem (Stop ServerError : r) a -> Sem r (Either ServerError a)
handleErrors =
      forall (r :: EffectRow) a.
Member Log r =>
Sem r (Either ServerError a) -> Sem r (Either ServerError a)
logErrors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err (r :: EffectRow) a.
Sem (Stop err : r) a -> Sem r (Either err a)
runStop @ServerError
    cons :: IO (Either ServerError a) -> Handler a
cons =
      forall a. ExceptT ServerError IO a -> Handler a
Handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
    handle :: ∀ x . Sem (Stop ServerError : r) x -> Handler x
    handle :: forall x. Sem (Stop ServerError : r) x -> Handler x
handle Sem (Stop ServerError : r) x
ma =
      forall {a}. IO (Either ServerError a) -> Handler a
cons (s (Either ServerError x) -> Either ServerError x
err forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. s (Sem r a) -> IO (s a)
lower (forall {a}.
Sem (Stop ServerError : r) a -> Sem r (Either ServerError a)
handleErrors Sem (Stop ServerError : r) x
ma forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ s ()
s))
      where
        err :: s (Either ServerError x) -> Either ServerError x
err =
          forall x. s x -> Maybe x
ins forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
            Just Either ServerError x
a -> Either ServerError x
a
            Maybe (Either ServerError x)
Nothing -> forall a b. a -> Either a b
Left ServerError
err500

-- | Run a Servant server using a callback in @'Final' 'IO'@, sending logs to 'Log'.
runServerSem ::
  ∀ (api :: Type) context r a .
  HasServer api context =>
  HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters =>
  Members [Log, Embed IO, Final IO] r =>
  ServerT api (Sem (Stop ServerError : r)) ->
  Context context ->
  (Application -> IO a) ->
  Sem r a
runServerSem :: forall api (context :: [*]) (r :: EffectRow) a.
(HasServer api context,
 HasContextEntry
   (context .++ DefaultErrorFormatters) ErrorFormatters,
 Members '[Log, Embed IO, Final IO] r) =>
ServerT api (Sem (Stop ServerError : r))
-> Context context -> (Application -> IO a) -> Sem r a
runServerSem ServerT api (Sem (Stop ServerError : r))
srv Context context
context Application -> IO a
f =
  forall (m :: * -> *) (r :: EffectRow) a.
Member (Final m) r =>
ThroughWeavingToFinal m (Sem r) a -> Sem r a
withWeavingToFinal \ f ()
s forall x. f (Sem r x) -> IO (f x)
lower forall x. f x -> Maybe x
ins ->
    (forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Application -> IO a
f (forall api (context :: [*]).
(HasServer api context, ServerContext context) =>
Proxy api -> Context context -> Server api -> Application
serveWithContext (forall {k} (t :: k). Proxy t
Proxy @api) Context context
context (forall api (context :: [*]) (r :: EffectRow) (s :: * -> *).
(Functor s, Member Log r, HasServer api context) =>
s ()
-> (forall a. s (Sem r a) -> IO (s a))
-> (forall x. s x -> Maybe x)
-> ServerT api (Sem (Stop ServerError : r))
-> Server api
lowerServer @api @context f ()
s forall x. f (Sem r x) -> IO (f x)
lower forall x. f x -> Maybe x
ins ServerT api (Sem (Stop ServerError : r))
srv))

toHandler :: IO (Maybe (Either ServerError a)) -> Handler a
toHandler :: forall a. IO (Maybe (Either ServerError a)) -> Handler a
toHandler =
  forall a. ExceptT ServerError IO a -> Handler a
Handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe (forall a b. a -> Either a b
Left ServerError
err500))

-- | Run a Servant server using Warp in @'Final' 'IO'@, sending logs to 'Log', registering the shutdown handler with
-- 'Interrupt'.
runServer ::
  ∀ (api :: Type) context r .
  HasServer api context =>
  HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters =>
  Members [Sync ServerReady, Log, Interrupt, Final IO] r =>
  ServerT api (Sem (Stop ServerError : r)) ->
  Context context ->
  Port ->
  Sem r ()
runServer :: forall api (context :: [*]) (r :: EffectRow).
(HasServer api context,
 HasContextEntry
   (context .++ DefaultErrorFormatters) ErrorFormatters,
 Members '[Sync ServerReady, Log, Interrupt, Final IO] r) =>
ServerT api (Sem (Stop ServerError : r))
-> Context context -> Port -> Sem r ()
runServer ServerT api (Sem (Stop ServerError : r))
srv Context context
context (Port Word
port) = do
  forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.info [exon|server port: #{show port}|]
  forall (m :: * -> *) (r :: EffectRow) a.
Member (Final m) r =>
ThroughWeavingToFinal m (Sem r) a -> Sem r a
withWeavingToFinal \ f ()
s forall x. f (Sem r x) -> IO (f x)
wv forall x. f x -> Maybe x
ins -> do
    let
      app :: Application
app =
        forall api (context :: [*]).
(HasServer api context, ServerContext context) =>
Proxy api -> Context context -> Server api -> Application
serveWithContext (forall {k} (t :: k). Proxy t
Proxy @api) Context context
context (forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy @api) (forall {k} (t :: k). Proxy t
Proxy @context) forall a. Sem (Stop ServerError : r) a -> Handler a
hoist ServerT api (Sem (Stop ServerError : r))
srv)
      hoist :: Sem (Stop ServerError : r) a -> Handler a
      hoist :: forall a. Sem (Stop ServerError : r) a -> Handler a
hoist =
        forall a. IO (Maybe (Either ServerError a)) -> Handler a
toHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall x. f x -> Maybe x
ins forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. f (Sem r x) -> IO (f x)
wv forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow) a.
Member Log r =>
Sem r (Either ServerError a) -> Sem r (Either ServerError a)
logErrors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err (r :: EffectRow) a.
Sem (Stop err : r) a -> Sem r (Either err a)
runStop @ServerError
      shut :: IO () -> IO ()
shut IO ()
h =
        forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall x. f (Sem r x) -> IO (f x)
wv (forall (r :: EffectRow).
Member Interrupt r =>
Text -> IO () -> Sem r ()
Interrupt.register Text
"api" IO ()
h forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
      settings :: Settings
settings =
        HostPreference -> Settings -> Settings
setHost HostPreference
"*6" forall a b. (a -> b) -> a -> b
$
        Int -> Settings -> Settings
setPort (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
port) forall a b. (a -> b) -> a -> b
$
        IO () -> Settings -> Settings
setBeforeMainLoop (forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall x. f (Sem r x) -> IO (f x)
wv (forall d (r :: EffectRow). Member (Sync d) r => d -> Sem r ()
Sync.putBlock ServerReady
ServerReady forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))) forall a b. (a -> b) -> a -> b
$
        (IO () -> IO ()) -> Settings -> Settings
setInstallShutdownHandler IO () -> IO ()
shut forall a b. (a -> b) -> a -> b
$
        Maybe Int -> Settings -> Settings
setGracefulShutdownTimeout (forall a. a -> Maybe a
Just Int
0) forall a b. (a -> b) -> a -> b
$
        Settings
defaultSettings
      log :: LogStr -> IO ()
log LogStr
msg =
        forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall x. f (Sem r x) -> IO (f x)
wv ((forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug (forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (LogStr -> ByteString
fromLogStr LogStr
msg))) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
    Middleware
logger <- RequestLoggerSettings -> IO Middleware
mkRequestLogger forall a. Default a => a
def { destination :: Destination
destination = (LogStr -> IO ()) -> Destination
Logger.Callback LogStr -> IO ()
log }
    (forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Application -> IO ()
Warp.runSettings Settings
settings (Middleware
logger Application
app)