{-# options_haddock prune #-}
-- |HTTP Server Plumbing, Internal
module Helic.Net.Server where

import Network.Wai (Application)
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Handler.Warp (
  defaultSettings,
  setBeforeMainLoop,
  setGracefulShutdownTimeout,
  setHost,
  setInstallShutdownHandler,
  setPort,
  )
import Network.Wai.Middleware.RequestLogger (logStdout)
import Polysemy.Conc (Interrupt, Sync)
import qualified Polysemy.Conc.Effect.Interrupt as Interrupt
import qualified Polysemy.Conc.Effect.Sync as Sync
import Polysemy.Final (withWeavingToFinal)
import Polysemy.Internal.Forklift (withLowerToIO)
import qualified Polysemy.Log as Log
import Polysemy.Log (Log)
import Servant (
  Context,
  DefaultErrorFormatters,
  ErrorFormatters,
  Handler (Handler),
  HasContextEntry,
  HasServer,
  Server,
  ServerError,
  ServerT,
  err500,
  errBody,
  hoistServerWithContext,
  serveWithContext,
  type (.++),
  )

newtype ApiError =
  ApiError { ApiError -> Text
unApiError :: Text }
  deriving stock (ApiError -> ApiError -> Bool
(ApiError -> ApiError -> Bool)
-> (ApiError -> ApiError -> Bool) -> Eq ApiError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApiError -> ApiError -> Bool
$c/= :: ApiError -> ApiError -> Bool
== :: ApiError -> ApiError -> Bool
$c== :: ApiError -> ApiError -> Bool
Eq, Int -> ApiError -> ShowS
[ApiError] -> ShowS
ApiError -> String
(Int -> ApiError -> ShowS)
-> (ApiError -> String) -> ([ApiError] -> ShowS) -> Show ApiError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiError] -> ShowS
$cshowList :: [ApiError] -> ShowS
show :: ApiError -> String
$cshow :: ApiError -> String
showsPrec :: Int -> ApiError -> ShowS
$cshowsPrec :: Int -> ApiError -> ShowS
Show)
  deriving newtype (String -> ApiError
(String -> ApiError) -> IsString ApiError
forall a. (String -> a) -> IsString a
fromString :: String -> ApiError
$cfromString :: String -> ApiError
IsString)

data ServerReady =
  ServerReady
  deriving (ServerReady -> ServerReady -> Bool
(ServerReady -> ServerReady -> Bool)
-> (ServerReady -> ServerReady -> Bool) -> Eq ServerReady
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
(Int -> ServerReady -> ShowS)
-> (ServerReady -> String)
-> ([ServerReady] -> ShowS)
-> Show ServerReady
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)

runApiError ::
  Member (Stop ServerError) r =>
  Sem (Stop ApiError : r) a ->
  Sem r a
runApiError :: Sem (Stop ApiError : r) a -> Sem r a
runApiError =
  (ApiError -> ServerError) -> Sem (Stop ApiError : r) a -> Sem r a
forall e e' (r :: EffectRow) a.
Member (Stop e') r =>
(e -> e') -> Sem (Stop e : r) a -> Sem r a
mapStop \case
  ApiError Text
msg ->
    ServerError
err500 { errBody :: ByteString
errBody = Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
msg }

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

liftServerPoly ::
  ∀ (api :: Type) context r .
  Member Log r =>
  HasServer api context =>
  (∀ a . Sem r a -> IO a) ->
  ServerT api (Sem (Stop ApiError : Stop ServerError : r)) ->
  Server api
liftServerPoly :: (forall a. Sem r a -> IO a)
-> ServerT api (Sem (Stop ApiError : Stop ServerError : r))
-> Server api
liftServerPoly forall a. Sem r a -> IO a
forklift ServerT api (Sem (Stop ApiError : Stop ServerError : r))
srv =
  Proxy api
-> Proxy context
-> (forall x.
    Sem (Stop ApiError : Stop ServerError : r) x -> Handler x)
-> ServerT api (Sem (Stop ApiError : Stop ServerError : r))
-> Server api
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 (Proxy api
forall k (t :: k). Proxy t
Proxy @api) (Proxy context
forall k (t :: k). Proxy t
Proxy @context) (IO (Either ServerError x) -> Handler x
forall a. IO (Either ServerError a) -> Handler a
cons (IO (Either ServerError x) -> Handler x)
-> (Sem (Stop ApiError : Stop ServerError : r) x
    -> IO (Either ServerError x))
-> Sem (Stop ApiError : Stop ServerError : r) x
-> Handler x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r (Either ServerError x) -> IO (Either ServerError x)
forall a. Sem r a -> IO a
forklift (Sem r (Either ServerError x) -> IO (Either ServerError x))
-> (Sem (Stop ApiError : Stop ServerError : r) x
    -> Sem r (Either ServerError x))
-> Sem (Stop ApiError : Stop ServerError : r) x
-> IO (Either ServerError x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Stop ApiError : Stop ServerError : r) x
-> Sem r (Either ServerError x)
forall a.
Sem (Stop ApiError : Stop ServerError : r) a
-> Sem r (Either ServerError a)
handleErrors) ServerT api (Sem (Stop ApiError : Stop ServerError : r))
srv
  where
    handleErrors :: Sem (Stop ApiError : Stop ServerError : r) a
-> Sem r (Either ServerError a)
handleErrors =
      Sem r (Either ServerError a) -> Sem r (Either ServerError a)
forall (r :: EffectRow) a.
Member Log r =>
Sem r (Either ServerError a) -> Sem r (Either ServerError a)
logErrors (Sem r (Either ServerError a) -> Sem r (Either ServerError a))
-> (Sem (Stop ApiError : Stop ServerError : r) a
    -> Sem r (Either ServerError a))
-> Sem (Stop ApiError : Stop ServerError : r) a
-> Sem r (Either ServerError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow) a.
Sem (Stop ServerError : r) a -> Sem r (Either ServerError a)
forall e (r :: EffectRow) a.
Sem (Stop e : r) a -> Sem r (Either e a)
runStop @ServerError (Sem (Stop ServerError : r) a -> Sem r (Either ServerError a))
-> (Sem (Stop ApiError : Stop ServerError : r) a
    -> Sem (Stop ServerError : r) a)
-> Sem (Stop ApiError : Stop ServerError : r) a
-> Sem r (Either ServerError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Stop ApiError : Stop ServerError : r) a
-> Sem (Stop ServerError : r) a
forall (r :: EffectRow) a.
Member (Stop ServerError) r =>
Sem (Stop ApiError : r) a -> Sem r a
runApiError
    cons :: IO (Either ServerError a) -> Handler a
cons =
      ExceptT ServerError IO a -> Handler a
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO a -> Handler a)
-> (IO (Either ServerError a) -> ExceptT ServerError IO a)
-> IO (Either ServerError a)
-> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ServerError a) -> ExceptT ServerError IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT

liftAppPoly ::
  ∀ (api :: Type) context r .
  Member Log r =>
  HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters =>
  HasServer api context =>
  ServerT api (Sem (Stop ApiError : Stop ServerError : r)) ->
  Context context ->
  (∀ a . Sem r a -> IO a) ->
  Application
liftAppPoly :: ServerT api (Sem (Stop ApiError : Stop ServerError : r))
-> Context context -> (forall a. Sem r a -> IO a) -> Application
liftAppPoly ServerT api (Sem (Stop ApiError : Stop ServerError : r))
srv Context context
context forall a. Sem r a -> IO a
forklift =
  Proxy api -> Context context -> Server api -> Application
forall api (context :: [*]).
(HasServer api context,
 HasContextEntry
   (context .++ DefaultErrorFormatters) ErrorFormatters) =>
Proxy api -> Context context -> Server api -> Application
serveWithContext (Proxy api
forall k (t :: k). Proxy t
Proxy @api) Context context
context (Server api -> Application) -> Server api -> Application
forall a b. (a -> b) -> a -> b
$ ((forall a. Sem r a -> IO a)
-> ServerT api (Sem (Stop ApiError : Stop ServerError : r))
-> Server api
forall api (context :: [*]) (r :: EffectRow).
(Member Log r, HasServer api context) =>
(forall a. Sem r a -> IO a)
-> ServerT api (Sem (Stop ApiError : Stop ServerError : r))
-> Server api
liftServerPoly @api @context forall a. Sem r a -> IO a
forklift ServerT api (Sem (Stop ApiError : Stop ServerError : r))
srv)

runServerSem ::
  ∀ (api :: Type) context r a .
  HasServer api context =>
  HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters =>
  Members [Log, Embed IO] r =>
  ServerT api (Sem (Stop ApiError : Stop ServerError : r)) ->
  Context context ->
  (Application -> IO a) ->
  Sem r a
runServerSem :: ServerT api (Sem (Stop ApiError : Stop ServerError : r))
-> Context context -> (Application -> IO a) -> Sem r a
runServerSem ServerT api (Sem (Stop ApiError : Stop ServerError : r))
srv Context context
context Application -> IO a
f =
  ((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
forall (r :: EffectRow) a.
Member (Embed IO) r =>
((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
withLowerToIO \ forall x. Sem r x -> IO x
forklift IO ()
_ ->
    Application -> IO a
f (ServerT api (Sem (Stop ApiError : Stop ServerError : r))
-> Context context -> (forall x. Sem r x -> IO x) -> Application
forall api (context :: [*]) (r :: EffectRow).
(Member Log r,
 HasContextEntry
   (context .++ DefaultErrorFormatters) ErrorFormatters,
 HasServer api context) =>
ServerT api (Sem (Stop ApiError : Stop ServerError : r))
-> Context context -> (forall a. Sem r a -> IO a) -> Application
liftAppPoly @api ServerT api (Sem (Stop ApiError : Stop ServerError : r))
srv Context context
context forall x. Sem r x -> IO x
forklift)

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

runServerWithContext ::
  ∀ (api :: Type) context r .
  HasServer api context =>
  HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters =>
  Members [Sync ServerReady, Log, Interrupt, Final IO] r =>
  ServerT api (Sem (Stop ApiError : Stop ServerError : r)) ->
  Context context ->
  Int ->
  Sem r ()
runServerWithContext :: ServerT api (Sem (Stop ApiError : Stop ServerError : r))
-> Context context -> Int -> Sem r ()
runServerWithContext ServerT api (Sem (Stop ApiError : Stop ServerError : r))
srv Context context
context Int
port = do
  Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.info [exon|server port: #{show port}|]
  ThroughWeavingToFinal IO (Sem r) () -> Sem r ()
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 =
        Proxy api -> Context context -> Server api -> Application
forall api (context :: [*]).
(HasServer api context,
 HasContextEntry
   (context .++ DefaultErrorFormatters) ErrorFormatters) =>
Proxy api -> Context context -> Server api -> Application
serveWithContext (Proxy api
forall k (t :: k). Proxy t
Proxy @api) Context context
context (Proxy api
-> Proxy context
-> (forall x.
    Sem (Stop ApiError : Stop ServerError : r) x -> Handler x)
-> ServerT api (Sem (Stop ApiError : Stop ServerError : r))
-> Server api
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 (Proxy api
forall k (t :: k). Proxy t
Proxy @api) (Proxy context
forall k (t :: k). Proxy t
Proxy @context) forall x. Sem (Stop ApiError : Stop ServerError : r) x -> Handler x
hoist ServerT api (Sem (Stop ApiError : Stop ServerError : r))
srv)
      hoist :: Sem (Stop ApiError : Stop ServerError : r) a -> Handler a
      hoist :: Sem (Stop ApiError : Stop ServerError : r) a -> Handler a
hoist =
        IO (Maybe (Either ServerError a)) -> Handler a
forall a. IO (Maybe (Either ServerError a)) -> Handler a
toHandler (IO (Maybe (Either ServerError a)) -> Handler a)
-> (Sem (Stop ApiError : Stop ServerError : r) a
    -> IO (Maybe (Either ServerError a)))
-> Sem (Stop ApiError : Stop ServerError : r) a
-> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (Either ServerError a) -> Maybe (Either ServerError a))
-> IO (f (Either ServerError a))
-> IO (Maybe (Either ServerError a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Either ServerError a) -> Maybe (Either ServerError a)
forall x. f x -> Maybe x
ins (IO (f (Either ServerError a))
 -> IO (Maybe (Either ServerError a)))
-> (Sem (Stop ApiError : Stop ServerError : r) a
    -> IO (f (Either ServerError a)))
-> Sem (Stop ApiError : Stop ServerError : r) a
-> IO (Maybe (Either ServerError a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem r (Either ServerError a)) -> IO (f (Either ServerError a))
forall x. f (Sem r x) -> IO (f x)
wv (f (Sem r (Either ServerError a)) -> IO (f (Either ServerError a)))
-> (Sem (Stop ApiError : Stop ServerError : r) a
    -> f (Sem r (Either ServerError a)))
-> Sem (Stop ApiError : Stop ServerError : r) a
-> IO (f (Either ServerError a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sem r (Either ServerError a)
-> f () -> f (Sem r (Either ServerError a))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) (Sem r (Either ServerError a) -> f (Sem r (Either ServerError a)))
-> (Sem (Stop ApiError : Stop ServerError : r) a
    -> Sem r (Either ServerError a))
-> Sem (Stop ApiError : Stop ServerError : r) a
-> f (Sem r (Either ServerError a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r (Either ServerError a) -> Sem r (Either ServerError a)
forall (r :: EffectRow) a.
Member Log r =>
Sem r (Either ServerError a) -> Sem r (Either ServerError a)
logErrors (Sem r (Either ServerError a) -> Sem r (Either ServerError a))
-> (Sem (Stop ApiError : Stop ServerError : r) a
    -> Sem r (Either ServerError a))
-> Sem (Stop ApiError : Stop ServerError : r) a
-> Sem r (Either ServerError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow) a.
Sem (Stop ServerError : r) a -> Sem r (Either ServerError a)
forall e (r :: EffectRow) a.
Sem (Stop e : r) a -> Sem r (Either e a)
runStop @ServerError (Sem (Stop ServerError : r) a -> Sem r (Either ServerError a))
-> (Sem (Stop ApiError : Stop ServerError : r) a
    -> Sem (Stop ServerError : r) a)
-> Sem (Stop ApiError : Stop ServerError : r) a
-> Sem r (Either ServerError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Stop ApiError : Stop ServerError : r) a
-> Sem (Stop ServerError : r) a
forall (r :: EffectRow) a.
Member (Stop ServerError) r =>
Sem (Stop ApiError : r) a -> Sem r a
runApiError
      shut :: IO () -> IO ()
shut IO ()
h =
        IO (f ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f (Sem r ()) -> IO (f ())
forall x. f (Sem r x) -> IO (f x)
wv (Text -> IO () -> Sem r ()
forall (r :: EffectRow).
Member Interrupt r =>
Text -> IO () -> Sem r ()
Interrupt.register Text
"api" IO ()
h Sem r () -> f () -> f (Sem r ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
      settings :: Settings
settings =
        HostPreference -> Settings -> Settings
setHost HostPreference
"*6" (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
        Int -> Settings -> Settings
setPort Int
port (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
        IO () -> Settings -> Settings
setBeforeMainLoop (IO (f ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f (Sem r ()) -> IO (f ())
forall x. f (Sem r x) -> IO (f x)
wv (ServerReady -> Sem r ()
forall d (r :: EffectRow). Member (Sync d) r => d -> Sem r ()
Sync.putBlock ServerReady
ServerReady Sem r () -> f () -> f (Sem r ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
        (IO () -> IO ()) -> Settings -> Settings
setInstallShutdownHandler IO () -> IO ()
shut (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
        Maybe Int -> Settings -> Settings
setGracefulShutdownTimeout (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
        Settings
defaultSettings
    (() -> f () -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) (() -> f ()) -> IO () -> IO (f ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Application -> IO ()
Warp.runSettings Settings
settings (Middleware
logStdout Application
app)