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

{- | The front door's cross-cutting middleware pieces and the control-plane health
endpoints: the drain-aware going-away header, the per-request timeout knob, and the
@\/livez@ \/ @\/readyz@ probe application. "Ecluse.Runtime.Server"'s @serverMiddleware@
composes the pieces around the proxy 'Application'; its dispatch answers the probes
through 'probeApplication'. The request-body cap is not here: it is a route concern,
enforced at the read site by the only body-consuming route (publish).
-}
module Ecluse.Runtime.Server.Middleware (
    -- * Drain-aware going-away header
    goingAwayMiddleware,

    -- * Per-request timeout
    timeoutSeconds,

    -- * Control-plane health probes
    probeApplication,

    -- * Neutral response shapes
    jsonResponse,
) where

import Network.HTTP.Types (Status, hConnection, hContentType, status200, status404, status503)
import Network.Wai (Application, Middleware, Response, mapResponseHeaders, modifyResponse, pathInfo, responseLBS)

import Ecluse.Runtime.Server.Drain (DrainSignal, isDraining)

{- | While the instance is draining, stamp @Connection: close@ on every response so a
keep-alive client (or a mesh connection pool) does not reuse the socket on a closing
instance; while serving, pass responses through untouched. The flag is read
per-response -- the same one-way 'DrainSignal' the readiness probe observes -- so the
header appears the moment the drain begins and on every response thereafter.
-}
goingAwayMiddleware :: DrainSignal -> Middleware
goingAwayMiddleware :: DrainSignal -> Middleware
goingAwayMiddleware DrainSignal
drain Application
app Request
request Response -> IO ResponseReceived
respond = do
    draining <- DrainSignal -> IO Bool
isDraining DrainSignal
drain
    if draining
        then modifyResponse closeConnection app request respond
        else app request respond
  where
    -- Add @Connection: close@ to the response's header set. A streaming response
    -- keeps streaming -- only its headers are rewritten.
    closeConnection :: Response -> Response
    closeConnection :: Response -> Response
closeConnection = (ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapResponseHeaders ((HeaderName
hConnection, ByteString
"close") Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
:)

{- | The per-request timeout, in seconds. Generous enough for a large packument
fetch, bounded so a stuck upstream cannot pin a handler indefinitely.
-}
timeoutSeconds :: Int
timeoutSeconds :: Int
timeoutSeconds = Int
60

{- | The control-plane health probes, answered above any mount: @\/livez@ from the
injected liveness check (the worker-heartbeat arm folded in by the caller),
@\/readyz@ from the drain signal ANDed with the composition root's startup gate,
and any other unmounted path as the neutral @404@.
-}
probeApplication :: DrainSignal -> IO Bool -> IO Bool -> Application
probeApplication :: DrainSignal -> IO Bool -> IO Bool -> Application
probeApplication DrainSignal
drain IO Bool
checkReady IO Bool
checkLiveness Request
request Response -> IO ResponseReceived
respond =
    case Request -> [Text]
pathInfo Request
request of
        [Text
"livez"] -> do
            alive <- IO Bool
checkLiveness
            if alive
                then respond (jsonResponse status200 "{\"status\":\"live\"}")
                else respond (jsonResponse status503 "{\"status\":\"liveness check failed\"}")
        [Text
"readyz"] -> DrainSignal -> IO Bool -> IO Response
readiness DrainSignal
drain IO Bool
checkReady IO Response
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO ResponseReceived
respond
        [Text]
_ -> Response -> IO ResponseReceived
respond Response
notFound

{- Readiness (@\/readyz@): @200@ when config is loaded and the listener is serving,
@503@ once the instance is __draining__. It is deliberately __lenient about
public-upstream reachability__ -- the proxy still serves private-upstream hits when
public is down -- so readiness must not flap on an upstream blip and pull a healthy
pod from rotation.

The drain flip is the load-balancer signal of a graceful rollover: while the
'DrainSignal' is raised, readiness fails so an upstream LB or service mesh stops
routing __new__ traffic here, while in-flight requests finish (see
@docs\/architecture\/web-layer.md@ → "Graceful shutdown").

The additional check is the composition root's startup gate (@scCheckReady@):
a one-way flip (today, the advisory database's first sync), so it cannot flap
a pod out of rotation once ready.
-}
readiness :: DrainSignal -> IO Bool -> IO Response
readiness :: DrainSignal -> IO Bool -> IO Response
readiness DrainSignal
drain IO Bool
checkReady =
    DrainSignal -> IO Bool
isDraining DrainSignal
drain IO Bool -> (Bool -> IO Response) -> IO Response
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status -> ByteString -> Response
jsonResponse Status
status503 ByteString
"{\"status\":\"draining\"}")
        Bool
False ->
            IO Bool
checkReady IO Bool -> (Bool -> Response) -> IO Response
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                Bool
False -> Status -> ByteString -> Response
jsonResponse Status
status503 ByteString
"{\"status\":\"awaiting startup readiness\"}"
                Bool
True -> Status -> ByteString -> Response
jsonResponse Status
status200 ByteString
"{\"status\":\"ready\"}"

{- A path matching no configured mount: a generic @404 Not Found@ in @text\/plain@.
This tier sits above the mounts, so there is no ecosystem to shape it -- the body is
kept as readable as possible to whatever client reached an unmounted path.
-}
notFound :: Response
notFound :: Response
notFound =
    Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 [(HeaderName
hContentType, ByteString
"text/plain; charset=utf-8")] ByteString
"Not Found\n"

-- | A JSON response with the given status and body, tagged @application\/json@.
jsonResponse :: Status -> LByteString -> Response
jsonResponse :: Status -> ByteString -> Response
jsonResponse Status
status =
    Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status [(HeaderName
hContentType, ByteString
"application/json")]