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

{- | The front door's cross-cutting middleware pieces and the control-plane health
endpoints. Those are the drain-aware going-away header 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,

    -- * Control-plane health probes
    probeApplication,

    -- * Neutral response shapes
    jsonResponse,
) where

import Data.Aeson (Value, encode, object, (.=))
import Data.Aeson.Key qualified as Key
import Data.Map.Strict qualified as Map
import Network.HTTP.Types (Status, hConnection, hContentType, status200, status404, status503)
import Network.Wai (Application, Middleware, Response, mapResponseHeaders, modifyResponse, pathInfo, responseLBS)

import Ecluse.Core.Ecosystem (Ecosystem, ecosystemName)
import Ecluse.Core.Server.Readiness (
    MountReadiness (MountAwaitingFirstSync, MountReady),
    Readiness (AwaitingMounts, Latched, Routable),
    routable,
 )
import Ecluse.Core.Worker (Liveness (liveHealthy, liveLastPoll))
import Ecluse.Runtime.Server.Drain (DrainSignal, isDraining)

{- | While the instance is draining, stamp @Connection: close@ on every response. A keep-alive
client or a mesh connection pool then stops reusing the socket on a closing instance.
-}
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

-- 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 control-plane health probes, answered above any mount: @\/livez@ from the injected
liveness check, @\/readyz@ from the drain signal and startup gate. Any other path is a @404@.
-}
probeApplication :: DrainSignal -> IO Readiness -> IO Liveness -> Application
probeApplication :: DrainSignal -> IO Readiness -> IO Liveness -> Application
probeApplication DrainSignal
drain IO Readiness
checkReady IO Liveness
checkLiveness Request
request Response -> IO ResponseReceived
respond =
    case Request -> [Text]
pathInfo Request
request of
        [Text
"livez"] -> IO Liveness
checkLiveness IO Liveness
-> (Liveness -> 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 (Response -> IO ResponseReceived)
-> (Liveness -> Response) -> Liveness -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Liveness -> Response
livenessResponse
        [Text
"readyz"] -> DrainSignal -> IO Readiness -> IO Response
readiness DrainSignal
drain IO Readiness
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

{- The @\/livez@ body carries the loop's last recorded progress beside the verdict, so a
dedicated worker fleet's orchestrator can judge staleness rather than only pass or fail. -}
livenessResponse :: Liveness -> Response
livenessResponse :: Liveness -> Response
livenessResponse Liveness
liveness
    | Liveness -> Bool
liveHealthy Liveness
liveness = Status -> Text -> Response
body Status
status200 Text
"live"
    | Bool
otherwise = Status -> Text -> Response
body Status
status503 Text
"liveness check failed"
  where
    body :: Status -> Text -> Response
    body :: Status -> Text -> Response
body Status
status Text
label =
        Status -> ByteString -> Response
jsonResponse Status
status (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode ([Pair] -> Value
object [Key
"status" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
label, Key
"lastPoll" Key -> Maybe UTCTime -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Liveness -> Maybe UTCTime
liveLastPoll Liveness
liveness]))

{- Readiness stays lenient about public-upstream reachability, because the proxy still serves
private-upstream hits when public is down. A blip must not flap a healthy pod out of rotation.
-}
readiness :: DrainSignal -> IO Readiness -> IO Response
readiness :: DrainSignal -> IO Readiness -> IO Response
readiness DrainSignal
drain IO Readiness
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 -> Text -> Response
statusOnly Status
status503 Text
"draining")
        Bool
False -> Readiness -> Response
readinessResponse (Readiness -> Response) -> IO Readiness -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Readiness
checkReady

{- The body names every configured mount beside the verdict, so an operator sees which ecosystem
awaits its advisory database while the others keep serving. -}
readinessResponse :: Readiness -> Response
readinessResponse :: Readiness -> Response
readinessResponse Readiness
verdict = case Readiness
verdict of
    Routable Map Ecosystem MountReadiness
mounts -> Text -> Map Ecosystem MountReadiness -> Response
forall {v}.
ToJSON v =>
v -> Map Ecosystem MountReadiness -> Response
withMounts Text
readyLabel Map Ecosystem MountReadiness
mounts
    AwaitingMounts Map Ecosystem MountReadiness
mounts -> Text -> Map Ecosystem MountReadiness -> Response
forall {v}.
ToJSON v =>
v -> Map Ecosystem MountReadiness -> Response
withMounts Text
awaitingLabel Map Ecosystem MountReadiness
mounts
    Readiness
Latched -> Status -> Text -> Response
statusOnly Status
status Text
"halted"
  where
    -- 'routable' alone decides the status, and the match decides only what the body reports.
    status :: Status
status = Status -> Status -> Bool -> Status
forall a. a -> a -> Bool -> a
bool Status
status503 Status
status200 (Readiness -> Bool
routable Readiness
verdict)
    withMounts :: v -> Map Ecosystem MountReadiness -> Response
withMounts v
label Map Ecosystem MountReadiness
mounts =
        Status -> ByteString -> Response
jsonResponse Status
status (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode ([Pair] -> Value
object [Key
"status" Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
label, Key
"mounts" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map Ecosystem MountReadiness -> Value
mountsOf Map Ecosystem MountReadiness
mounts]))

-- A mount reports the two words the whole verdict reports, under its configured ecosystem key.
mountsOf :: Map.Map Ecosystem MountReadiness -> Value
mountsOf :: Map Ecosystem MountReadiness -> Value
mountsOf Map Ecosystem MountReadiness
mounts =
    [Pair] -> Value
object [Text -> Key
Key.fromText (Ecosystem -> Text
ecosystemName Ecosystem
eco) Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= MountReadiness -> Text
mountLabel MountReadiness
mount | (Ecosystem
eco, MountReadiness
mount) <- Map Ecosystem MountReadiness -> [(Ecosystem, MountReadiness)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Ecosystem MountReadiness
mounts]

mountLabel :: MountReadiness -> Text
mountLabel :: MountReadiness -> Text
mountLabel = \case
    MountReadiness
MountReady -> Text
readyLabel
    MountReadiness
MountAwaitingFirstSync -> Text
awaitingLabel

readyLabel, awaitingLabel :: Text
readyLabel :: Text
readyLabel = Text
"ready"
-- Only a mount that denies on the advisory database waits, so the label names what is missing and
-- which role publishes it rather than reporting a generic startup delay.
awaitingLabel :: Text
awaitingLabel = Text
"awaiting the advisory database that ecluse pilot publishes"

-- A probe body carrying the verdict alone, for a state no mount detail explains.
statusOnly :: Status -> Text -> Response
statusOnly :: Status -> Text -> Response
statusOnly Status
status Text
label = Status -> ByteString -> Response
jsonResponse Status
status (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode ([Pair] -> Value
object [Key
"status" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
label]))

-- This tier sits above the mounts, so no ecosystem shapes the body of 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")]