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

{- | The proxy listener runs beside the role's worker and advisory-sync tasks.
"Ecluse.Service" supplies its mounts and probes.
-}
module Ecluse.Proxy (
    runProxy,
    runServer,
) where

import Katip (LogEnv, Severity (ErrorS), SimpleLogPayload, katipAddContext, logFM, runKatipContextT, sl)
import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp qualified as Warp
import UnliftIO (concurrently_, race_)
import UnliftIO.Async (mapConcurrently_)

import Ecluse.Boot (applyServerSettings)
import Ecluse.Config (AppConfig (cfgServer))
import Ecluse.Core.Text (displayExceptionT)
import Ecluse.Runtime.Env (Env, envLogEnv)
import Ecluse.Runtime.Server (
    ServerConfig (scCheckLive, scCheckReady, scOnException),
    mkServerConfig,
 )
import Ecluse.Runtime.Server qualified as Server
import Ecluse.Service (ServiceRuntime (..), runWorker)

-- | Run the listener and cancel its background tasks when the HTTP drain ends.
runProxy :: ServiceRuntime -> IO ()
runProxy :: ServiceRuntime -> IO ()
runProxy ServiceRuntime
runtime =
    -- The background tasks never return, so the race cancels them at shutdown. A dropped job
    -- re-enqueues on the next demand and a cancelled sync resumes on next boot.
    case ServiceRuntime -> Maybe (IO ())
svcMirrorDrain ServiceRuntime
runtime of
        Maybe (IO ())
Nothing -> IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_ IO ()
frontDoor ((IO () -> IO ()) -> [IO ()] -> IO ()
forall (m :: * -> *) (f :: * -> *) a b.
(MonadUnliftIO m, Foldable f) =>
(a -> m b) -> f a -> m ()
mapConcurrently_ IO () -> IO ()
forall a. a -> a
id [IO ()]
tasks)
        Just IO ()
drain -> IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_ IO ()
frontDoor (IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ IO ()
drain ((IO () -> IO ()) -> [IO ()] -> IO ()
forall (m :: * -> *) (f :: * -> *) a b.
(MonadUnliftIO m, Foldable f) =>
(a -> m b) -> f a -> m ()
mapConcurrently_ IO () -> IO ()
forall a. a -> a
id [IO ()]
tasks))
  where
    -- The memory sampler always runs, so the list is never empty and the race never ends at once.
    tasks :: [IO ()]
tasks = ServiceRuntime -> IO ()
svcMemorySampler ServiceRuntime
runtime IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: ServiceRuntime -> [IO ()]
svcSyncTasks ServiceRuntime
runtime
    env :: Env
env = ServiceRuntime -> Env
svcEnv ServiceRuntime
runtime
    serverConfig :: ServerConfig
serverConfig = ServiceRuntime -> ServerConfig
proxyServerConfig ServiceRuntime
runtime
    frontDoor :: IO ()
frontDoor
        -- The worker loop never returns, so the server's graceful return must cancel it,
        -- never wait on it.
        | ServiceRuntime -> Bool
svcRunsWorker ServiceRuntime
runtime =
            IO () -> IO () -> IO ()
forall (m :: * -> *). MonadUnliftIO m => m () -> m () -> m ()
Server.raceServerAgainstLoop (ServerConfig -> Env -> IO ()
runServer ServerConfig
serverConfig Env
env) (WorkerPolicies -> Env -> IO ()
runWorker (ServiceRuntime -> WorkerPolicies
svcWorkerPolicies ServiceRuntime
runtime) Env
env)
        | Bool
otherwise = ServerConfig -> Env -> IO ()
runServer ServerConfig
serverConfig Env
env

proxyServerConfig :: ServiceRuntime -> ServerConfig
proxyServerConfig :: ServiceRuntime -> ServerConfig
proxyServerConfig ServiceRuntime
runtime =
    (ServerSettings -> ServerConfig -> ServerConfig
applyServerSettings (AppConfig -> ServerSettings
cfgServer (ServiceRuntime -> AppConfig
svcAppConfig ServiceRuntime
runtime)) ([MountBinding] -> ServerConfig
mkServerConfig (ServiceRuntime -> [MountBinding]
svcBindings ServiceRuntime
runtime)))
        { scCheckReady = svcCheckReady runtime
        , scCheckLive = svcCheckLive runtime
        , scOnException = warpExceptionHook (envLogEnv (svcEnv runtime))
        }

-- | Run the proxy listener with the mounted adapters and shared process resources.
runServer :: ServerConfig -> Env -> IO ()
runServer :: ServerConfig -> Env -> IO ()
runServer ServerConfig
cfg Env
env = LogEnv
-> Text
-> ServerConfig
-> (ServerConfig -> IO Application)
-> IO ()
Server.runWarp (Env -> LogEnv
envLogEnv Env
env) Text
Server.proxyListener ServerConfig
cfg (ServerConfig -> Env -> IO Application
`Server.tracedApplication` Env
env)

{- Warp's exception hook over the process logger. 'Warp.defaultShouldDisplayException'
filters routine client disconnects, so an aborted download does not spam the log. -}
warpExceptionHook :: LogEnv -> Maybe Wai.Request -> SomeException -> IO ()
warpExceptionHook :: LogEnv -> Maybe Request -> SomeException -> IO ()
warpExceptionHook LogEnv
logEnv Maybe Request
mRequest SomeException
err =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Bool
Warp.defaultShouldDisplayException SomeException
err) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        LogEnv
-> SimpleLogPayload -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv (SimpleLogPayload
forall a. Monoid a => a
mempty :: SimpleLogPayload) Namespace
"server" (KatipContextT IO () -> IO ()) -> KatipContextT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            SimpleLogPayload -> KatipContextT IO () -> KatipContextT IO ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (KatipContextT IO () -> KatipContextT IO ())
-> KatipContextT IO () -> KatipContextT IO ()
forall a b. (a -> b) -> a -> b
$
                Severity -> LogStr -> KatipContextT IO ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
ErrorS LogStr
"a fault escaped to the server (a post-commit teardown, or warp's own connection handling)"
  where
    payload :: SimpleLogPayload
payload =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"path" (Text -> (Request -> Text) -> Maybe Request -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text
"unknown" :: Text) (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> (Request -> ByteString) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ByteString
Wai.rawPathInfo) Maybe Request
mRequest)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"detail" (SomeException -> Text
forall e. Exception e => e -> Text
displayExceptionT SomeException
err)