{-# options_haddock prune #-}

-- |HTTP Server Plumbing, Internal
module Helic.Net.Server where

import Control.Monad.Trans.Except (ExceptT (ExceptT))
import Exon (exon)
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 qualified Polysemy.Conc.Sync as Sync
import Polysemy.Final (withWeavingToFinal)
import qualified Polysemy.Log as Log
import Servant (
  Context,
  DefaultErrorFormatters,
  ErrorFormatters,
  Handler (Handler),
  HasContextEntry,
  HasServer,
  ServerError,
  ServerT,
  err500,
  hoistServerWithContext,
  serveWithContext,
  type (.++),
  )
import System.Log.FastLogger (fromLogStr)

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 stock (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)

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)

toHandler :: IO (Maybe a) -> Handler a
toHandler :: IO (Maybe 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 a) -> ExceptT ServerError IO a)
-> IO (Maybe 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 a) -> IO (Either ServerError a))
-> IO (Maybe a)
-> ExceptT ServerError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Either ServerError a)
-> IO (Maybe a) -> IO (Either ServerError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either ServerError a
-> (a -> Either ServerError a) -> Maybe a -> Either ServerError a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ServerError -> Either ServerError a
forall a b. a -> Either a b
Left ServerError
err500) a -> Either ServerError a
forall a b. b -> Either a b
Right)

runServerWithContext ::
  ∀ (api :: Type) context r .
  HasServer api context =>
  HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters =>
  Members [Sync ServerReady, Log, Interrupt, Final IO] r =>
  ServerT api (Sem r) ->
  Context context ->
  Int ->
  Sem r ()
runServerWithContext :: ServerT api (Sem r) -> Context context -> Int -> Sem r ()
runServerWithContext ServerT api (Sem 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 r x -> Handler x)
-> ServerT api (Sem 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 r x -> Handler x
hoist ServerT api (Sem r)
srv)
      hoist :: Sem r a -> Handler a
      hoist :: Sem r a -> Handler a
hoist =
        IO (Maybe a) -> Handler a
forall a. IO (Maybe a) -> Handler a
toHandler (IO (Maybe a) -> Handler a)
-> (Sem r a -> IO (Maybe a)) -> Sem r a -> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a -> Maybe a) -> IO (f a) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> Maybe a
forall x. f x -> Maybe x
ins (IO (f a) -> IO (Maybe a))
-> (Sem r a -> IO (f a)) -> Sem r a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem r a) -> IO (f a)
forall x. f (Sem r x) -> IO (f x)
wv (f (Sem r a) -> IO (f a))
-> (Sem r a -> f (Sem r a)) -> Sem r a -> IO (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sem r a -> f () -> f (Sem r a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
      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
      log :: LogStr -> IO ()
log LogStr
msg =
        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 -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (LogStr -> ByteString
fromLogStr LogStr
msg))) Sem r () -> f () -> f (Sem r ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
    Middleware
logger <- RequestLoggerSettings -> IO Middleware
mkRequestLogger RequestLoggerSettings
forall a. Default a => a
def { destination :: Destination
destination = (LogStr -> IO ()) -> Destination
Logger.Callback LogStr -> IO ()
log }
    (() -> 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
logger Application
app)