-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | The dispatch, the request perimeter and the listener behind "Ecluse.Runtime.Server", which
documents the front door and re-exports the curated surface. Importing this module opts out of
that stability promise, the convention @text@ and @bytestring@ use, so production code imports
the public one.
-}
module Ecluse.Runtime.Server.Internal (
    -- * The WAI application
    ServerConfig (..),
    mkServerConfig,
    defaultPort,
    MountBinding (..),
    application,
    tracedApplication,

    -- * Running the server
    runWarp,
    serveBound,
    proxyListener,
    listeningPrefix,
    raceServerAgainstLoop,
    probeApplication,
    probeOnlyApplication,

    -- * The typed request perimeter
    perimeterGuard,

    -- * Graceful shutdown
    DrainSignal,
    newDrainSignal,
    neverDraining,
    beginDrain,
    isDraining,
    ShutdownDrainTimeout (..),
    defaultShutdownDrainTimeout,

    -- * Local-dev immediate halt
    InteractiveHalt (..),
    defaultInteractiveHalt,
    withInteractiveHalt,

    -- * Middleware
    serverMiddleware,
) where

import Data.List (dropWhileEnd)
import Data.Streaming.Network (bindPortTCP)
import Katip (LogEnv, Severity (ErrorS, InfoS), SimpleLogPayload, katipAddContext, logFM, sl)
import Network.HTTP.Types (Method, status500)
import Network.HTTP.Types.Header (RequestHeaders)
import Network.Socket (close, setCloseOnExecIfNeeded, socketPort, withFdSocket, withSocketsDo)
import Network.Wai (Application, Middleware, Request, Response, ResponseReceived, pathInfo, rawPathInfo, requestHeaders, requestMethod)
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Middleware.RealIp (realIp)
import Network.Wai.Middleware.Timeout (timeout)
import System.Posix.Signals qualified as Posix
import UnliftIO (MonadUnliftIO)
import UnliftIO.Async (race_)
import UnliftIO.Exception (bracket, catchAny, throwIO)

import Ecluse.Core.Security (requestTimeoutSeconds)
import Ecluse.Core.Server.Context (
    Handler,
    MountBinding (..),
    RequestCtx (RequestCtx, ctxRuntime),
    ResponseAction (AnswerLocally, AnswerRefusal, RunPipeline),
    RouteAction (RouteAction),
    ServeRuntime (srMetrics),
    pdHelp,
    runHandler,
 )
import Ecluse.Core.Server.Contract (responseToWai)
import Ecluse.Core.Server.Fault (RequestFault (rqCause, rqDetail), classifyEscape)
import Ecluse.Core.Server.Readiness (Readiness, alwaysReady)
import Ecluse.Core.Telemetry.Record (MetricsPort (mpRequestPerimeterFault))
import Ecluse.Core.Worker (Liveness, alwaysLive)
import Ecluse.Runtime.Env (Env, envDdContext, envLogEnv, envTelemetry, serveRuntimeOf)
import Ecluse.Runtime.Log (moduleLog)
import Ecluse.Runtime.Server.Drain (
    DrainSignal,
    ShutdownDrainTimeout (..),
    beginDrain,
    defaultShutdownDrainTimeout,
    isDraining,
    neverDraining,
    newDrainSignal,
 )
import Ecluse.Runtime.Server.Halt (
    InteractiveHalt (..),
    defaultInteractiveHalt,
    withInteractiveHalt,
 )
import Ecluse.Runtime.Server.Middleware (
    goingAwayMiddleware,
    jsonResponse,
    probeApplication,
 )
import Ecluse.Runtime.Telemetry.Correlation (ddPayloadNow)
import Ecluse.Runtime.Telemetry.Tracing (telemetryWaiMiddleware)

{- | The settings the web layer needs to serve that the composition-root 'Env' does not carry.
Not the request-body cap: the publish route bounds its own body as a value.
-}
data ServerConfig = ServerConfig
    { ServerConfig -> Int
scPort :: Int
    -- ^ The TCP port @warp@ listens on.
    , ServerConfig -> [MountBinding]
scMounts :: [MountBinding]
    {- ^ The mounts served. The first whose prefix matches the request's leading segments
    wins, and a path under no mount is the neutral @404@.
    -}
    , ServerConfig -> DrainSignal
scDrain :: DrainSignal
    {- ^ The shutdown-drain flag the front door observes. Once raised, the readiness probe
    fails and every response carries @Connection: close@. Defaults to 'neverDraining'.
    -}
    , ServerConfig -> ShutdownDrainTimeout
scDrainTimeout :: ShutdownDrainTimeout
    {- ^ How long the graceful drain waits for in-flight requests and in-progress
    artifact streams to finish before the process exits ('defaultShutdownDrainTimeout').
    -}
    , ServerConfig -> IO Readiness
scCheckReady :: IO Readiness
    {- ^ The readiness verdict the composition root installs, which @\/readyz@ renders and the
    drain check overrides. Each mount's flip is one way, so readiness never flaps a pod out of rotation.
    -}
    , ServerConfig -> IO Liveness
scCheckLive :: IO Liveness
    {- ^ The liveness check @\/livez@ answers from, beyond the listener itself. A worker
    heartbeat is wired here only when a worker runs, so a serve-only deployment stays live.
    -}
    , ServerConfig -> Maybe Request -> SomeException -> IO ()
scOnException :: Maybe Request -> SomeException -> IO ()
    {- ^ @warp@'s exception hook, for a post-commit escape the request perimeter rethrew or a
    fault in warp's own connection handling. The 'mkServerConfig' default is inert.
    -}
    }

{- | Build a 'ServerConfig' over the mount bindings on 'defaultPort'. There is no built-in
mount: the web layer serves only the ecosystems the composition root binds here.
-}
mkServerConfig :: [MountBinding] -> ServerConfig
mkServerConfig :: [MountBinding] -> ServerConfig
mkServerConfig [MountBinding]
mounts =
    ServerConfig
        { scPort :: Int
scPort = Int
defaultPort
        , scMounts :: [MountBinding]
scMounts = [MountBinding]
mounts
        , scDrain :: DrainSignal
scDrain = DrainSignal
neverDraining
        , scDrainTimeout :: ShutdownDrainTimeout
scDrainTimeout = ShutdownDrainTimeout
defaultShutdownDrainTimeout
        , scCheckReady :: IO Readiness
scCheckReady = Readiness -> IO Readiness
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Readiness
alwaysReady
        , scCheckLive :: IO Liveness
scCheckLive = Liveness -> IO Liveness
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Liveness
alwaysLive
        , scOnException :: Maybe Request -> SomeException -> IO ()
scOnException = \Maybe Request
_ SomeException
_ -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        }

-- | The conventional npm proxy listen port (4873), the 'mkServerConfig' default.
defaultPort :: Int
defaultPort :: Int
defaultPort = Int
4873

{- | The proxy's WAI 'Application': the request dispatch under the cross-cutting
middleware stack ('serverMiddleware').
-}
application :: ServerConfig -> Env -> Application
application :: ServerConfig -> Env -> Application
application ServerConfig
cfg Env
env = ServerConfig -> Middleware
serverMiddleware ServerConfig
cfg (ServerConfig -> Env -> Application
dispatch ServerConfig
cfg Env
env)

{- | The WAI 'Application' of a role that serves the health probes and nothing else. Every
path outside @\/livez@ and @\/readyz@ is the neutral @404@.
-}
probeOnlyApplication :: ServerConfig -> IO Application
probeOnlyApplication :: ServerConfig -> IO Application
probeOnlyApplication ServerConfig
cfg = Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerConfig -> Middleware
serverMiddleware ServerConfig
cfg (ServerConfig -> Application
probesOf ServerConfig
cfg))

-- The health probes over one config's drain signal and injected checks.
probesOf :: ServerConfig -> Application
probesOf :: ServerConfig -> Application
probesOf ServerConfig
cfg = DrainSignal -> IO Readiness -> IO Liveness -> Application
probeApplication (ServerConfig -> DrainSignal
scDrain ServerConfig
cfg) (ServerConfig -> IO Readiness
scCheckReady ServerConfig
cfg) (ServerConfig -> IO Liveness
scCheckLive ServerConfig
cfg)

{- | 'application' with the OpenTelemetry server-span middleware wrapped __outermost__, so
one server span covers the whole request. The wrapper is 'id' when telemetry is off.
-}
tracedApplication :: ServerConfig -> Env -> IO Application
tracedApplication :: ServerConfig -> Env -> IO Application
tracedApplication ServerConfig
cfg Env
env = do
    traceMiddleware <- Telemetry -> IO Middleware
telemetryWaiMiddleware (Env -> Telemetry
envTelemetry Env
env)
    pure (traceMiddleware (application cfg env))

{- Route a request: the first matching mount wins, and every other path falls to the
health probes, which answer @\/livez@ and @\/readyz@ and give the rest the neutral @404@.
-}
dispatch :: ServerConfig -> Env -> Application
dispatch :: ServerConfig -> Env -> Application
dispatch ServerConfig
cfg Env
env Request
request Response -> IO ResponseReceived
respond =
    case ByteString
-> RequestHeaders
-> [MountBinding]
-> [Text]
-> Maybe (MountBinding, RouteAction)
matchMount (Request -> ByteString
requestMethod Request
request) (Request -> RequestHeaders
requestHeaders Request
request) (ServerConfig -> [MountBinding]
scMounts ServerConfig
cfg) (Request -> [Text]
pathInfo Request
request) of
        Just (MountBinding
binding, RouteAction
action) -> Env -> MountBinding -> RouteAction -> Application
serve Env
env MountBinding
binding RouteAction
action Request
request Response -> IO ResponseReceived
respond
        Maybe (MountBinding, RouteAction)
Nothing -> ServerConfig -> Application
probesOf ServerConfig
cfg Request
request Response -> IO ResponseReceived
respond

{- Carry out the action the matched mount's router named. A 'RunPipeline' action runs
under the typed request perimeter, over the 'RequestCtx' this function builds once.
-}
serve :: Env -> MountBinding -> RouteAction -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
serve :: Env -> MountBinding -> RouteAction -> Application
serve Env
env MountBinding
binding (RouteAction ResponseContract response
contract ResponseAction response
action) Request
request Response -> IO ResponseReceived
respond =
    case ResponseAction response
action of
        AnswerLocally response
answer -> response -> IO ResponseReceived
send response
answer
        -- This is where a route's own refusal meets the mount's help message: the table decides
        -- the refusal, and the binding beside it renders the body.
        AnswerRefusal Maybe HelpMessage -> response
render -> response -> IO ResponseReceived
send (Maybe HelpMessage -> response
render (PackumentDeps -> Maybe HelpMessage
pdHelp (MountBinding -> PackumentDeps
bindingPackumentDeps MountBinding
binding)))
        RunPipeline response
fallback Request
-> (response -> IO ResponseReceived) -> Handler ResponseReceived
handler ->
            (RequestFault -> IO ())
-> (response -> IO ResponseReceived)
-> response
-> ((response -> IO ResponseReceived) -> IO ResponseReceived)
-> IO ResponseReceived
forall response.
(RequestFault -> IO ())
-> (response -> IO ResponseReceived)
-> response
-> ((response -> IO ResponseReceived) -> IO ResponseReceived)
-> IO ResponseReceived
perimeterGuard
                (Env -> RequestCtx -> Request -> RequestFault -> IO ()
observePerimeterFault Env
env RequestCtx
ctx Request
request)
                response -> IO ResponseReceived
send
                response
fallback
                (Env
-> RequestCtx -> Handler ResponseReceived -> IO ResponseReceived
forall a. Env -> RequestCtx -> Handler a -> IO a
runInRequest Env
env RequestCtx
ctx (Handler ResponseReceived -> IO ResponseReceived)
-> ((response -> IO ResponseReceived) -> Handler ResponseReceived)
-> (response -> IO ResponseReceived)
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request
-> (response -> IO ResponseReceived) -> Handler ResponseReceived
handler Request
request)
  where
    send :: response -> IO ResponseReceived
send response
value = Response -> IO ResponseReceived
respond (ResponseContract response -> response -> Response
forall response. ResponseContract response -> response -> Response
responseToWai ResponseContract response
contract response
value)

    ctx :: RequestCtx
    ctx :: RequestCtx
ctx = ServeRuntime -> MountBinding -> RequestCtx
RequestCtx (Env -> ServeRuntime
serveRuntimeOf Env
env) MountBinding
binding

-- Discharge a 'Handler' to 'IO' over the per-request context. Resolving @dd@ here is what makes
-- every serve-path log line carry its trace correlation.
runInRequest :: Env -> RequestCtx -> Handler a -> IO a
runInRequest :: forall a. Env -> RequestCtx -> Handler a -> IO a
runInRequest Env
env RequestCtx
ctx Handler a
action = do
    dd <- DdContext -> IO SimpleLogPayload
forall (m :: * -> *). MonadIO m => DdContext -> m SimpleLogPayload
ddPayloadNow (Env -> DdContext
envDdContext Env
env)
    runHandler (envLogEnv env) dd ctx action

-- Record an escaped pre-commit fault on the metric and the audit line, both before the
-- perimeter answers its neutral fallback.
observePerimeterFault :: Env -> RequestCtx -> Request -> RequestFault -> IO ()
observePerimeterFault :: Env -> RequestCtx -> Request -> RequestFault -> IO ()
observePerimeterFault Env
env RequestCtx
ctx Request
request RequestFault
fault = do
    MetricsPort -> RequestFaultCause -> IO ()
mpRequestPerimeterFault (ServeRuntime -> MetricsPort
srMetrics (RequestCtx -> ServeRuntime
ctxRuntime RequestCtx
ctx)) (RequestFault -> RequestFaultCause
rqCause RequestFault
fault)
    Env -> RequestCtx -> Handler () -> IO ()
forall a. Env -> RequestCtx -> Handler a -> IO a
runInRequest Env
env RequestCtx
ctx (Handler () -> IO ())
-> (Handler () -> Handler ()) -> Handler () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleLogPayload -> Handler () -> Handler ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext (Request -> RequestFault -> SimpleLogPayload
perimeterPayload Request
request RequestFault
fault) (Handler () -> IO ()) -> Handler () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Severity -> LogStr -> Handler ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
ErrorS LogStr
"the request perimeter answered an escaped pre-commit fault with the neutral 500"

-- The fields mirror the denial audit line, so an operator triages both surfaces with one
-- vocabulary. The @module@ key names the public module, because operators filter on it.
perimeterPayload :: Request -> RequestFault -> SimpleLogPayload
perimeterPayload :: Request -> RequestFault -> SimpleLogPayload
perimeterPayload Request
request RequestFault
fault =
    Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" (Text
"Ecluse.Runtime.Server" :: Text)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"path" (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Request -> ByteString
rawPathInfo Request
request) :: Text)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"perimeterCause" (RequestFaultCause -> Text
forall b a. (Show a, IsString b) => a -> b
show (RequestFault -> RequestFaultCause
rqCause RequestFault
fault) :: Text)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"perimeterDetail" (RequestFault -> Text
rqDetail RequestFault
fault)

{- | Run one route's handler behind a commit-tracking respond, catching __synchronous__ escapes
only. Pre-commit one answers the neutral fallback with no detail, post-commit it rethrows.
-}
perimeterGuard ::
    -- | Observe a classified pre-commit fault (the metric and the audit line).
    (RequestFault -> IO ()) ->
    -- | The route-scoped response continuation.
    (response -> IO ResponseReceived) ->
    -- | The route's declared neutral pre-commit fallback.
    response ->
    -- | The route's handler, discharged to 'IO', awaiting the tracked respond.
    ((response -> IO ResponseReceived) -> IO ResponseReceived) ->
    IO ResponseReceived
perimeterGuard :: forall response.
(RequestFault -> IO ())
-> (response -> IO ResponseReceived)
-> response
-> ((response -> IO ResponseReceived) -> IO ResponseReceived)
-> IO ResponseReceived
perimeterGuard RequestFault -> IO ()
observeFault response -> IO ResponseReceived
respond response
fallback (response -> IO ResponseReceived) -> IO ResponseReceived
handlerOn = do
    committed <- Bool -> IO (IORef Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Bool
False
    let respondCommitted response
response = do
            IORef Bool -> Bool -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef IORef Bool
committed Bool
True
            response -> IO ResponseReceived
respond response
response
    handlerOn respondCommitted `catchAny` \SomeException
escape -> do
        wasCommitted <- IORef Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Bool
committed
        if wasCommitted
            then throwIO escape
            else do
                observeFault (classifyEscape escape)
                respond fallback

{- Match a request path to a mount: the first binding whose prefix the path begins with, paired
with the action its router names. A prefix matches with or without a trailing slash.
-}
matchMount :: Method -> RequestHeaders -> [MountBinding] -> [Text] -> Maybe (MountBinding, RouteAction)
matchMount :: ByteString
-> RequestHeaders
-> [MountBinding]
-> [Text]
-> Maybe (MountBinding, RouteAction)
matchMount ByteString
method RequestHeaders
headers [MountBinding]
mounts [Text]
segments = [Maybe (MountBinding, RouteAction)]
-> Maybe (MountBinding, RouteAction)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ((MountBinding -> Maybe (MountBinding, RouteAction))
-> [MountBinding] -> [Maybe (MountBinding, RouteAction)]
forall a b. (a -> b) -> [a] -> [b]
map MountBinding -> Maybe (MountBinding, RouteAction)
match [MountBinding]
mounts)
  where
    {- The method and the headers are part of the mapping: the npm router tells a @PUT@ publish
    from a @GET@ over one path, and a media-typed route refuses a client that admits none. -}
    match :: MountBinding -> Maybe (MountBinding, RouteAction)
    match :: MountBinding -> Maybe (MountBinding, RouteAction)
match MountBinding
binding =
        (MountBinding
binding,) (RouteAction -> (MountBinding, RouteAction))
-> ([Text] -> RouteAction) -> [Text] -> (MountBinding, RouteAction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountBinding -> MountRouter
bindingRouter MountBinding
binding ByteString
method RequestHeaders
headers
            ([Text] -> (MountBinding, RouteAction))
-> Maybe [Text] -> Maybe (MountBinding, RouteAction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> [Text] -> Maybe [Text]
stripPrefixSegments (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (MountBinding -> NonEmpty Text
bindingPrefix MountBinding
binding)) [Text]
segments

-- Strip a mount's prefix segments off the front of a request path. The first equation is the
-- base case a fully-consumed prefix reaches, which is where the trailing slash is dropped.
stripPrefixSegments :: [Text] -> [Text] -> Maybe [Text]
stripPrefixSegments :: [Text] -> [Text] -> Maybe [Text]
stripPrefixSegments [] [Text]
segs = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> [Text]
dropTrailingSlashes [Text]
segs)
stripPrefixSegments (Text
p : [Text]
ps) (Text
s : [Text]
ss)
    | Text
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s = [Text] -> [Text] -> Maybe [Text]
stripPrefixSegments [Text]
ps [Text]
ss
stripPrefixSegments [Text]
_ [Text]
_ = Maybe [Text]
forall a. Maybe a
Nothing

-- A trailing slash arrives as an empty final segment (@\/npm\/@ as @["npm",""]@). An
-- internal empty segment is left untouched for the router to reject.
dropTrailingSlashes :: [Text] -> [Text]
dropTrailingSlashes :: [Text] -> [Text]
dropTrailingSlashes = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"")

{- | The cross-cutting stack around the proxy 'Application'. The body cap is not a middleware:
it would throw across the request perimeter, and @Autohead@ and @Gzip@ fight streaming.
-}
serverMiddleware :: ServerConfig -> Middleware
serverMiddleware :: ServerConfig -> Middleware
serverMiddleware ServerConfig
cfg =
    Middleware
realIp
        Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Middleware
timeout Int
requestTimeoutSeconds
        Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrainSignal -> Middleware
goingAwayMiddleware (ServerConfig -> DrainSignal
scDrain ServerConfig
cfg)

{- | Serve the front door over one live 'DrainSignal', which the probe, the going-away header,
and the shutdown handler share. @warp@ drains under 'scDrainTimeout', and a TTY adds Ctrl-D.
-}
runWarp :: LogEnv -> Text -> ServerConfig -> (ServerConfig -> IO Application) -> IO ()
runWarp :: LogEnv
-> Text
-> ServerConfig
-> (ServerConfig -> IO Application)
-> IO ()
runWarp LogEnv
logEnv Text
listener ServerConfig
cfg0 ServerConfig -> IO Application
getApp = do
    drain <- IO DrainSignal
newDrainSignal
    let cfg = ServerConfig
cfg0{scDrain = drain}
        ShutdownDrainTimeout timeoutSecs = scDrainTimeout cfg
        settings =
            Int -> Settings -> Settings
Warp.setPort (ServerConfig -> Int
scPort ServerConfig
cfg)
                (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO () -> IO ()) -> Settings -> Settings
Warp.setInstallShutdownHandler (DrainSignal -> IO () -> IO ()
installShutdownHandler DrainSignal
drain)
                (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Settings -> Settings
Warp.setGracefulShutdownTimeout (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
timeoutSecs)
                (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException (ServerConfig -> Maybe Request -> SomeException -> IO ()
scOnException ServerConfig
cfg)
                -- Defence in depth for a fault with no mount context, from a middleware or
                -- warp itself: a neutral 500 with no detail. A handler escape never gets here.
                (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> Response) -> Settings -> Settings
Warp.setOnExceptionResponse (Response -> SomeException -> Response
forall a b. a -> b -> a
const Response
onExceptionResponse)
                (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
Warp.defaultSettings
    app <- getApp cfg
    withInteractiveHalt defaultInteractiveHalt (serveBound logEnv listener settings app)

-- | Bind as 'Warp.runSettings' does, log the bound port, then serve.
serveBound :: LogEnv -> Text -> Warp.Settings -> Application -> IO ()
serveBound :: LogEnv -> Text -> Settings -> Application -> IO ()
serveBound LogEnv
logEnv Text
listener Settings
settings Application
app =
    IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Int -> HostPreference -> IO Socket
bindPortTCP (Settings -> Int
Warp.getPort Settings
settings) (Settings -> HostPreference
Warp.getHost Settings
settings)) Socket -> IO ()
close ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
socket -> do
            Socket -> (CInt -> IO ()) -> IO ()
forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
socket CInt -> IO ()
setCloseOnExecIfNeeded
            port <- Socket -> IO PortNumber
socketPort Socket
socket
            Warp.runSettingsSocket (Warp.setBeforeMainLoop (announce port) settings) socket app
  where
    announce :: a -> IO ()
announce a
port = LogEnv -> Text -> Severity -> Text -> IO ()
moduleLog LogEnv
logEnv Text
"Ecluse.Runtime.Server" Severity
InfoS (Text -> Text
listeningPrefix Text
listener Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
port :: Int))

-- | The proxy's listener name, which starts the line it logs once bound.
proxyListener :: Text
proxyListener :: Text
proxyListener = Text
"proxy"

-- | The start of the line a named listener logs once bound, followed by the port.
listeningPrefix :: Text -> Text
listeningPrefix :: Text -> Text
listeningPrefix Text
listener = Text
listener Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" listening on port "

-- The neutral response for a fault that escapes to warp's own handler (see 'runWarp'):
-- a deny-shaped 500 carrying no exception detail.
onExceptionResponse :: Response
onExceptionResponse :: Response
onExceptionResponse = Status -> LByteString -> Response
jsonResponse Status
status500 LByteString
"{\"error\":\"internal server error\"}"

{- On @SIGTERM@ or @SIGINT@, raise the drain before closing the socket, so readiness fails and
responses carry @Connection: close@ first. 'CatchOnce' leaves the second to the runtime.
-}
installShutdownHandler :: DrainSignal -> IO () -> IO ()
installShutdownHandler :: DrainSignal -> IO () -> IO ()
installShutdownHandler DrainSignal
drain IO ()
closeSocket =
    (CInt -> IO Handler) -> [CInt] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ CInt -> IO Handler
install [CInt
Posix.sigTERM, CInt
Posix.sigINT]
  where
    install :: CInt -> IO Handler
install CInt
sig = CInt -> Handler -> Maybe SignalSet -> IO Handler
Posix.installHandler CInt
sig (IO () -> Handler
Posix.CatchOnce (DrainSignal -> IO ()
beginDrain DrainSignal
drain IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
closeSocket)) Maybe SignalSet
forall a. Maybe a
Nothing

{- | Race a server arm against a never-returning background loop, the single-process shutdown
shape. 'race_' is the invariant: 'concurrently_' would wait forever, brackets un-unwound.
-}
raceServerAgainstLoop :: (MonadUnliftIO m) => m () -> m () -> m ()
raceServerAgainstLoop :: forall (m :: * -> *). MonadUnliftIO m => m () -> m () -> m ()
raceServerAgainstLoop = m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_