-- TupleSections: pairing a matched mount with its classified remainder in
-- 'dispatchMount' ((mount,) . classifier); see STYLE.md §2.
{-# LANGUAGE TupleSections #-}

{- | The HTTP front door: the raw @wai@ 'Application', its dispatch, the
meta-routes, the middleware stack, and 'runServer'.

The proxy is a passthrough over a small, irregular URL surface, so the front
door is a raw 'Application' rather than a web framework -- matching on @pathInfo@
keeps the encoded-slash handling and the streaming control the proxy depends on
(see @docs\/architecture\/web-layer.md@). Routing is two layers:

* __Mount dispatch__ -- match a request's leading path segments to a configured
  'MountBinding', strip the prefix, and hand the remainder (an ecosystem-native
  path) to that mount's 'Ecluse.Core.Server.Route.Classifier'. A binding carries a
  mount's __complete__ ecosystem wiring -- its classifier, its packument-serve
  dependencies, and its error 'Ecluse.Core.Server.Response.MountRenderer' -- so the web
  layer is closed over the shared 'Route' set ("Ecluse.Core.Server.Route") and holds no
  ecosystem's path grammar or body shape of its own. Every registry is
  __path-mounted__ (e.g. @\/npm@); there is no root mount, so adding an ecosystem
  never changes an existing consumer's URLs. A mount prefix is accepted with or
  without a trailing slash (see @docs\/architecture\/hosting.md@ → "Dispatch").

Responses split into __two tiers__:

* __Above the mounts -- neutral, server-owned.__ The orchestration health probes
  (@\/livez@, @\/readyz@) are answered at the top level, and a path matching __no__
  configured mount is a generic @404 Not Found@ in @text\/plain@ -- there is no
  ecosystem to shape it.

* __Within a matched mount -- the mount's renderer.__ The classified 'Route'
  renders through that mount's 'Ecluse.Core.Server.Response.MountRenderer', in the
  ecosystem's own error surface: @\/-\/ping@ is answered locally with @200 {}@,
  @\/-\/v1\/search@ is @501@ (search is not an install path), an unrecognised
  in-mount path is @404@ (deny by default), and the package\/artifact routes
  ('Packument', 'Tarball') are recognised but, without serve dependencies wired,
  return an explicit @501 Not Implemented@ rather than a fabricated success -- their
  fetch → rules → serve pipeline lives outside this module.

Cross-cutting concerns are applied as middleware composed around the
'Application' (see @docs\/architecture\/web-layer.md@ → "Middleware"): a
defensive request-body size cap, correct client-IP recovery behind a load
balancer, and a request timeout. Dispatch builds a per-request
'Ecluse.Core.Server.Context.RequestCtx' -- the request runtime ('serveRuntimeOf')
paired with the matched 'MountBinding' -- and the effectful routes run in the
'Ecluse.Core.Server.Context.Handler' reader over it, so a handler reads its mount's
wiring and the request runtime from context rather than as threaded arguments.
-}
module Ecluse.Server (
    -- * The WAI application
    ServerConfig (..),
    mkServerConfig,
    defaultPort,
    MountBinding (..),
    application,
    tracedApplication,

    -- * Running the server
    runWarp,
    probeApplication,

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

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

    -- * Middleware
    serverMiddleware,

    -- * Request-body cap
    RequestSizeLimit (..),
    defaultRequestSizeLimit,
) where

import Network.HTTP.Types (Method, Status, hConnection, hContentType, methodHead, status200, status404, status501, status503)
import Network.Wai (Application, Middleware, Request, Response, ResponseReceived, mapResponseHeaders, modifyResponse, pathInfo, requestMethod, responseLBS)
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Middleware.RealIp (realIp)
import Network.Wai.Middleware.RequestSizeLimit (defaultRequestSizeLimitSettings, requestSizeLimitMiddleware, setMaxLengthForRequest)
import Network.Wai.Middleware.Timeout (timeout)
import System.Exit (ExitCode (ExitFailure))
import System.IO (hIsTerminalDevice, isEOF)
import System.Posix.Process (exitImmediately)
import System.Posix.Signals (Handler (CatchOnce), installHandler, sigINT, sigTERM)
import UnliftIO.Async (withAsync)

import Ecluse.Core.Server.Context (
    MountBinding (..),
    RequestCtx (RequestCtx),
    runHandler,
 )
import Ecluse.Core.Server.Pipeline (headPackument, headTarball, servePackument, servePublish, serveTarball)
import Ecluse.Core.Server.Response (MountRenderer, RenderedBody (RenderedBody), renderError)
import Ecluse.Core.Server.Route (Route (..))
import Ecluse.Core.Worker (heartbeatHealthyNow)
import Ecluse.Env (Env, envDdContext, envLogEnv, envTelemetry, envWorkerHeartbeat, serveRuntimeOf)
import Ecluse.Telemetry.Correlation (ddPayloadNow)
import Ecluse.Telemetry.Tracing (telemetryWaiMiddleware)

{- | The server's own settings -- the values the 'Application' and 'runServer'
need that the composition-root 'Env' does not carry: the listen port, the served
mount bindings, and the request-body cap. Backend selection is a composition-root
concern; this is the minimal shape the web layer needs to route.
-}
data ServerConfig = ServerConfig
    { ServerConfig -> Int
scPort :: Int
    -- ^ The TCP port @warp@ listens on.
    , ServerConfig -> [MountBinding]
scMounts :: [MountBinding]
    {- ^ The mounts served, tried in order; the first whose prefix matches the
    request's leading segments wins. A deployment with no mounts serves nothing
    beyond the health probes -- every other path is the neutral @404@.
    -}
    , ServerConfig -> RequestSizeLimit
scSizeLimit :: RequestSizeLimit
    -- ^ The defensive cap on request-body size.
    , ServerConfig -> DrainSignal
scDrain :: DrainSignal
    {- ^ The shared shutdown-drain flag the front door observes: once raised, the
    readiness probe fails ('readiness') and responses carry @Connection: close@
    (the going-away middleware), so a load balancer stops routing new traffic to
    this instance and clients stop reusing keep-alive sockets to it. Defaults to
    'neverDraining'; 'runServer' replaces it with a live signal it flips on a
    shutdown signal.
    -}
    , 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 Bool
scCheckReady :: IO Bool
    {- ^ An additional readiness gate the composition root installs, ANDed with
    the drain check by @\/readyz@. Today it is the advisory database's
    first-sync signal: a one-way flip per configured ecosystem, so readiness
    never flaps on it, and @'pure' True@ (the 'mkServerConfig' default) when no
    advisory bucket is configured. The listener serves regardless, since an
    absent advisory database only ever abstains into deny-by-default; this
    gates what a load balancer routes, not whether the process answers.
    -}
    }

{- | Build a 'ServerConfig' over the given mount bindings, taking the default
listen port ('defaultPort') and request-body cap ('defaultRequestSizeLimit').

The composition root supplies the bindings -- each a mount's complete ecosystem
wiring -- and overrides the port or cap by record update where a deployment needs
to. There is no built-in mount: an ecosystem is served only once its binding is
passed here, so the web layer carries no ecosystem of its own.
-}
mkServerConfig :: [MountBinding] -> ServerConfig
mkServerConfig :: [MountBinding] -> ServerConfig
mkServerConfig [MountBinding]
mounts =
    ServerConfig
        { scPort :: Int
scPort = Int
defaultPort
        , scMounts :: [MountBinding]
scMounts = [MountBinding]
mounts
        , scSizeLimit :: RequestSizeLimit
scSizeLimit = RequestSizeLimit
defaultRequestSizeLimit
        , scDrain :: DrainSignal
scDrain = DrainSignal
neverDraining
        , scDrainTimeout :: ShutdownDrainTimeout
scDrainTimeout = ShutdownDrainTimeout
defaultShutdownDrainTimeout
        , scCheckReady :: IO Bool
scCheckReady = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        }

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

{- | The maximum request-body size accepted, in bytes -- a defensive cap so a
hostile or runaway client cannot force the proxy to buffer an unbounded body. A
'newtype' so a raw byte count is not mistaken for some other 'Word64'.
-}
newtype RequestSizeLimit = RequestSizeLimit Word64
    deriving stock (RequestSizeLimit -> RequestSizeLimit -> Bool
(RequestSizeLimit -> RequestSizeLimit -> Bool)
-> (RequestSizeLimit -> RequestSizeLimit -> Bool)
-> Eq RequestSizeLimit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RequestSizeLimit -> RequestSizeLimit -> Bool
== :: RequestSizeLimit -> RequestSizeLimit -> Bool
$c/= :: RequestSizeLimit -> RequestSizeLimit -> Bool
/= :: RequestSizeLimit -> RequestSizeLimit -> Bool
Eq, Int -> RequestSizeLimit -> ShowS
[RequestSizeLimit] -> ShowS
RequestSizeLimit -> String
(Int -> RequestSizeLimit -> ShowS)
-> (RequestSizeLimit -> String)
-> ([RequestSizeLimit] -> ShowS)
-> Show RequestSizeLimit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RequestSizeLimit -> ShowS
showsPrec :: Int -> RequestSizeLimit -> ShowS
$cshow :: RequestSizeLimit -> String
show :: RequestSizeLimit -> String
$cshowList :: [RequestSizeLimit] -> ShowS
showList :: [RequestSizeLimit] -> ShowS
Show)

{- | The default request-body cap: 25 MiB. Generous for the metadata and small
control-plane bodies the proxy accepts (artifact __downloads__ stream the other
way and are never buffered), while still bounding a hostile upload.
-}
defaultRequestSizeLimit :: RequestSizeLimit
defaultRequestSizeLimit :: RequestSizeLimit
defaultRequestSizeLimit = Word64 -> RequestSizeLimit
RequestSizeLimit (Word64
25 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1024 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1024)

{- | The shared shutdown-drain flag the front door observes during a graceful
rollover, as a small handle (a reader plus a one-way raise) rather than a bare
'TVar' -- so the same field can hold either a live, flip-once signal ('newDrainSignal')
or the inert 'neverDraining' constant the socket-free tests assemble against, and
nothing downstream can lower it back. It is raised once, on a shutdown signal, and
read on every request by the readiness probe and the going-away middleware.
-}
data DrainSignal = DrainSignal
    { DrainSignal -> STM Bool
drainState :: STM Bool
    -- ^ Whether the instance is draining: 'False' while serving, 'True' once raised.
    , DrainSignal -> STM ()
drainRaise :: STM ()
    -- ^ Raise the flag. Idempotent -- a second raise is a no-op.
    }

{- | Allocate a live, lowered shutdown-drain signal backed by a 'TVar'. 'runServer'
allocates one per launch and flips it from the signal handler; the @application@ it
builds reads the very same signal, so the readiness probe and the going-away
middleware see the drain the instant the handler raises it.
-}
newDrainSignal :: IO DrainSignal
newDrainSignal :: IO DrainSignal
newDrainSignal = do
    tvar <- Bool -> IO (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
False
    pure
        DrainSignal
            { drainState = readTVar tvar
            , drainRaise = writeTVar tvar True
            }

{- | The inert drain signal: permanently lowered, raising it is a no-op. The
'mkServerConfig' default, so an @application@ assembled for a socket-free test (and
one driven without ever entering shutdown) reports ready and adds no going-away
header. A real launch overrides it with 'newDrainSignal' in 'runServer'.
-}
neverDraining :: DrainSignal
neverDraining :: DrainSignal
neverDraining =
    DrainSignal
        { drainState :: STM Bool
drainState = Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        , drainRaise :: STM ()
drainRaise = () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        }

-- | Raise a drain signal -- the one-way transition into draining. Idempotent.
beginDrain :: DrainSignal -> IO ()
beginDrain :: DrainSignal -> IO ()
beginDrain = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ())
-> (DrainSignal -> STM ()) -> DrainSignal -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrainSignal -> STM ()
drainRaise

-- | Read whether a drain signal is raised.
isDraining :: DrainSignal -> IO Bool
isDraining :: DrainSignal -> IO Bool
isDraining = STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> IO Bool)
-> (DrainSignal -> STM Bool) -> DrainSignal -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrainSignal -> STM Bool
drainState

{- | The bound on the graceful drain: how many seconds the server waits for
in-flight requests and in-progress artifact streams to finish after it stops
accepting new connections, before the process exits regardless. A @newtype@ so a
raw seconds count is not mistaken for some other 'Int', and so a non-positive value
cannot be passed where a positive timeout is meant (see 'runServer').
-}
newtype ShutdownDrainTimeout = ShutdownDrainTimeout Int
    deriving stock (ShutdownDrainTimeout -> ShutdownDrainTimeout -> Bool
(ShutdownDrainTimeout -> ShutdownDrainTimeout -> Bool)
-> (ShutdownDrainTimeout -> ShutdownDrainTimeout -> Bool)
-> Eq ShutdownDrainTimeout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShutdownDrainTimeout -> ShutdownDrainTimeout -> Bool
== :: ShutdownDrainTimeout -> ShutdownDrainTimeout -> Bool
$c/= :: ShutdownDrainTimeout -> ShutdownDrainTimeout -> Bool
/= :: ShutdownDrainTimeout -> ShutdownDrainTimeout -> Bool
Eq, Int -> ShutdownDrainTimeout -> ShowS
[ShutdownDrainTimeout] -> ShowS
ShutdownDrainTimeout -> String
(Int -> ShutdownDrainTimeout -> ShowS)
-> (ShutdownDrainTimeout -> String)
-> ([ShutdownDrainTimeout] -> ShowS)
-> Show ShutdownDrainTimeout
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShutdownDrainTimeout -> ShowS
showsPrec :: Int -> ShutdownDrainTimeout -> ShowS
$cshow :: ShutdownDrainTimeout -> String
show :: ShutdownDrainTimeout -> String
$cshowList :: [ShutdownDrainTimeout] -> ShowS
showList :: [ShutdownDrainTimeout] -> ShowS
Show)

{- | The default graceful-drain bound: 30 seconds. Long enough for an in-flight
metadata fetch or a moderate artifact stream to complete during a rolling deploy,
short enough that a stuck request cannot pin the old instance indefinitely.
-}
defaultShutdownDrainTimeout :: ShutdownDrainTimeout
defaultShutdownDrainTimeout :: ShutdownDrainTimeout
defaultShutdownDrainTimeout = Int -> ShutdownDrainTimeout
ShutdownDrainTimeout Int
30

{- | The local-development immediate-halt wiring, as three injection points so its
logic is exercised without a real terminal. It exists only to give an interactive
session a "quit now" key: when the server is attached to a TTY, closing standard
input (Ctrl-D) forces an __immediate__ process exit, aborting any in-progress drain
-- the same hard-stop a second Ctrl-C gives, but on the dev's deliberate signal.

It is __inert outside an interactive terminal__: in production standard input is a
non-TTY or closed, 'haltOnInteractive' returns 'False', and no watcher is installed,
so the signal-driven graceful lifecycle is completely untouched. The TTY guard is
what enforces that zero-production-impact contract (see 'withInteractiveHalt').
-}
data InteractiveHalt = InteractiveHalt
    { InteractiveHalt -> IO Bool
haltOnInteractive :: IO Bool
    {- ^ Whether to arm the halt at all -- the production guard. The real wiring is
    "is standard input a terminal?", so a non-interactive process never installs the
    watcher.
    -}
    , InteractiveHalt -> IO ()
awaitHaltSignal :: IO ()
    {- ^ Block until the dev's halt signal. The real wiring reads standard input
    until end-of-input (Ctrl-D); it returns when the watcher should fire.
    -}
    , InteractiveHalt -> IO ()
halt :: IO ()
    {- ^ The halt itself: terminate the process __immediately__, bypassing the drain
    wait. The real wiring is a direct @_exit@ ('exitImmediately'), matching the
    second-Ctrl-C hard stop.
    -}
    }

{- | The real local-dev halt: armed only when standard input is a terminal
('hIsTerminalDevice'), fired by end-of-input on standard input (Ctrl-D), and
halting via 'exitImmediately' -- an immediate @_exit@ that bypasses the graceful
drain, mirroring a second Ctrl-C. The exit status (130) is the conventional
"terminated from the terminal" code.
-}
defaultInteractiveHalt :: InteractiveHalt
defaultInteractiveHalt :: InteractiveHalt
defaultInteractiveHalt =
    InteractiveHalt
        { haltOnInteractive :: IO Bool
haltOnInteractive = Handle -> IO Bool
hIsTerminalDevice Handle
stdin
        , awaitHaltSignal :: IO ()
awaitHaltSignal = IO ()
awaitStdinEof
        , halt :: IO ()
halt = ExitCode -> IO ()
forall a. ExitCode -> IO a
exitImmediately (Int -> ExitCode
ExitFailure Int
130)
        }
  where
    -- Read and discard standard input until end-of-input. On an interactive
    -- terminal this blocks until the dev presses Ctrl-D (or the stream otherwise
    -- closes); typed lines in between are consumed and ignored -- the watcher only
    -- cares about the close.
    awaitStdinEof :: IO ()
    awaitStdinEof :: IO ()
awaitStdinEof = IO ()
go
      where
        go :: IO ()
go =
            IO Bool
isEOF IO Bool -> (Bool -> IO ()) -> IO ()
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 -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
                Bool
False -> IO Text -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Text
forall (m :: * -> *). MonadIO m => m Text
getLine 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 ()
go

{- | Run an action with the local-dev immediate-halt watcher armed __only when
interactive__. If 'haltOnInteractive' is 'True', a watcher runs alongside the action
for exactly its lifetime ('withAsync', so it is torn down when the action returns or
is cancelled -- it never lingers); the watcher blocks on 'awaitHaltSignal' and, when
that returns, runs 'halt'. If 'False' -- the production case -- the action runs alone,
with no watcher and no extra thread, so nothing about the graceful lifecycle changes.
-}
withInteractiveHalt :: InteractiveHalt -> IO a -> IO a
withInteractiveHalt :: forall a. InteractiveHalt -> IO a -> IO a
withInteractiveHalt InteractiveHalt
ih IO a
action =
    InteractiveHalt -> IO Bool
haltOnInteractive InteractiveHalt
ih IO Bool -> (Bool -> IO a) -> IO a
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
False -> IO a
action
        Bool
True -> IO () -> (Async () -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (InteractiveHalt -> IO ()
awaitHaltSignal InteractiveHalt
ih IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InteractiveHalt -> IO ()
halt InteractiveHalt
ih) (IO a -> Async () -> IO a
forall a b. a -> b -> a
const IO a
action)

{- | Build the proxy's WAI 'Application' over a 'ServerConfig' and the
composition-root 'Env', with the middleware stack composed around it.

The bare app dispatches a request: a control-plane health probe (@\/livez@ \/
@\/readyz@) is answered at the top level; otherwise the leading path segment is
matched to a mount, the prefix stripped, and the remainder classified and
rendered. The returned 'Application' has the middleware applied (body cap,
client-IP recovery, timeout).
-}
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)

{- | Build the proxy 'Application' with the OpenTelemetry server-span middleware
wrapped __outermost__ around 'application', so one server span covers the whole
request (the other middlewares included). When telemetry is disabled the wrapper is
'id', so this is exactly 'application' -- additive and inert off (see
"Ecluse.Telemetry.Tracing"). 'runServer' serves through this; a caller embedding the
proxy that wants the request trace builds its application here rather than through
the bare 'application'.
-}
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))

{- Dispatch a request to its handler. Top-level health probes are answered first,
above any mount. Otherwise the leading path segments are matched to a mount: a
match routes the remainder through that mount's binding; no match is the neutral
@404@, since there is no ecosystem to render it.
-}
dispatch :: ServerConfig -> Env -> Application
dispatch :: ServerConfig -> Env -> Application
dispatch ServerConfig
cfg Env
env Request
request Response -> IO ResponseReceived
respond =
    case ByteString
-> [MountBinding] -> [Text] -> Maybe (MountBinding, Route)
matchMount (Request -> ByteString
requestMethod Request
request) (ServerConfig -> [MountBinding]
scMounts ServerConfig
cfg) (Request -> [Text]
pathInfo Request
request) of
        Just (MountBinding
binding, Route
classified) -> Env -> MountBinding -> Route -> Application
serve Env
env MountBinding
binding Route
classified Request
request Response -> IO ResponseReceived
respond
        Maybe (MountBinding, Route)
Nothing -> DrainSignal -> IO Bool -> IO Bool -> Application
probeApplication (ServerConfig -> DrainSignal
scDrain ServerConfig
cfg) (ServerConfig -> IO Bool
scCheckReady ServerConfig
cfg) (WorkerHeartbeat -> IO Bool
heartbeatHealthyNow (Env -> WorkerHeartbeat
envWorkerHeartbeat Env
env)) Request
request Response -> IO ResponseReceived
respond

{- Serve a classified route under its matched mount. Dispatch builds the
per-request 'RequestCtx' once -- the request runtime ('serveRuntimeOf') paired with the
matched 'MountBinding' -- and the effectful 'Packument' and 'Tarball' routes run in the
'Handler' reader over it, so the handler reads the mount's serve dependencies and
renderer from context rather than as threaded arguments (the deps-or-@501@ decision
is the handler's). Every other route renders to a pure 'Response' through the
mount's renderer.

A @HEAD@ on the 'Tarball' route is dispatched to 'headTarball', which gates the
artifact identically to the @GET@ path but probes the upstream as a @HEAD@ and relays
the headers with no body -- so a bodiless @HEAD@ can never open and pump the full
artifact body (the reason @Autohead@ is deliberately not used; see 'serverMiddleware').
A @HEAD@ on the 'Packument' route is likewise dispatched to 'headPackument', which runs
the identical gating and merge as the @GET@ path and emits the same status and headers
(the would-be body's @Content-Length@ and the own @ETag@) with no body -- the
HTTP-correctness half of explicit-@HEAD@ handling (a packument body is assembled
locally, so it carries no artifact-egress amplification).

The 'Publish' route (a @PUT \/{pkg}@, recognised by the method-aware classifier) is
dispatched to 'servePublish', the first-party publish relay: it enforces the
anti-shadowing scope guard before any write and relays the publish to the publication
target with the publisher's own forwarded credential, or @405@ when no publication
target is configured (the opt-in is off).
-}
serve :: Env -> MountBinding -> Route -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
serve :: Env -> MountBinding -> Route -> Application
serve Env
env MountBinding
binding Route
classified Request
request Response -> IO ResponseReceived
respond =
    case Route
classified of
        Packument PackageName
name
            | Bool
isHead -> Handler ResponseReceived -> IO ResponseReceived
forall {b}. Handler b -> IO b
run (PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
headPackument PackageName
name Request
request Response -> IO ResponseReceived
respond)
            | Bool
otherwise -> Handler ResponseReceived -> IO ResponseReceived
forall {b}. Handler b -> IO b
run (PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
servePackument PackageName
name Request
request Response -> IO ResponseReceived
respond)
        Tarball PackageName
name Version
version Filename
filename
            | Bool
isHead -> Handler ResponseReceived -> IO ResponseReceived
forall {b}. Handler b -> IO b
run (PackageName
-> Version
-> Filename
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
headTarball PackageName
name Version
version Filename
filename Request
request Response -> IO ResponseReceived
respond)
            | Bool
otherwise -> Handler ResponseReceived -> IO ResponseReceived
forall {b}. Handler b -> IO b
run (PackageName
-> Version
-> Filename
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
serveTarball PackageName
name Version
version Filename
filename Request
request Response -> IO ResponseReceived
respond)
        Publish PackageName
name -> Handler ResponseReceived -> IO ResponseReceived
forall {b}. Handler b -> IO b
run (PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
servePublish PackageName
name Request
request Response -> IO ResponseReceived
respond)
        Route
_ -> Response -> IO ResponseReceived
respond (MountRenderer -> Route -> Response
renderRoute (MountBinding -> MountRenderer
bindingRenderer MountBinding
binding) Route
classified)
  where
    -- Discharge a 'Handler' to 'IO' over the per-request context, establishing the
    -- @katip@ logging context the application owns: the composition root's 'LogEnv'
    -- (scribes) and the resolved trace-correlation @dd@ object as the initial context,
    -- so every serve-path line carries @dd@. The request runtime the handler reads is
    -- projected from 'Env' ('serveRuntimeOf').
    run :: Handler b -> IO b
run Handler b
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

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

    isHead :: Bool
    isHead :: Bool
isHead = Request -> ByteString
requestMethod Request
request ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
methodHead

{- Match a request path to a mount: the first binding whose prefix the path begins
with, paired with the remainder classified through that mount's classifier.
'Nothing' when no mount's prefix matches -- the caller then answers the neutral
@404@. A mount prefix is accepted with or without a trailing slash, so @\/npm\/pkg@
and a bare @\/npm@ both match the @\/npm@ mount.
-}
matchMount :: Method -> [MountBinding] -> [Text] -> Maybe (MountBinding, Route)
matchMount :: ByteString
-> [MountBinding] -> [Text] -> Maybe (MountBinding, Route)
matchMount ByteString
method [MountBinding]
mounts [Text]
segments = [Maybe (MountBinding, Route)] -> Maybe (MountBinding, Route)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ((MountBinding -> Maybe (MountBinding, Route))
-> [MountBinding] -> [Maybe (MountBinding, Route)]
forall a b. (a -> b) -> [a] -> [b]
map MountBinding -> Maybe (MountBinding, Route)
match [MountBinding]
mounts)
  where
    -- The binding whose prefix the path begins with, paired with the classified
    -- remainder -- the method threaded so a 'Publish' (a @PUT@) is told apart from a
    -- read over the same path. 'Nothing' for a non-matching prefix.
    match :: MountBinding -> Maybe (MountBinding, Route)
    match :: MountBinding -> Maybe (MountBinding, Route)
match MountBinding
binding =
        (MountBinding
binding,) (Route -> (MountBinding, Route))
-> ([Text] -> Route) -> [Text] -> (MountBinding, Route)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountBinding -> Classifier
bindingClassifier MountBinding
binding ByteString
method
            ([Text] -> (MountBinding, Route))
-> Maybe [Text] -> Maybe (MountBinding, Route)
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 root
mount (an empty prefix) consumes nothing and always matches. A trailing empty
segment left after the prefix -- the trailing slash of a bare @\/npm\/@ -- is
dropped so it is not mistaken for an empty ecosystem path component.
-}
stripPrefixSegments :: [Text] -> [Text] -> Maybe [Text]
stripPrefixSegments :: [Text] -> [Text] -> Maybe [Text]
stripPrefixSegments [] [Text]
segs = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> [Text]
dropTrailingSlash [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 single trailing empty segment (a bare-mount trailing slash, e.g. @\/npm\/@
-- arriving as @["npm",""]@) is dropped so the remainder is the empty path, not a
-- spurious empty component. A non-trailing empty segment is left untouched for
-- the router to reject.
dropTrailingSlash :: [Text] -> [Text]
dropTrailingSlash :: [Text] -> [Text]
dropTrailingSlash [Text
""] = []
dropTrailingSlash (Text
x : [Text]
xs) = Text
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
dropTrailingSlash [Text]
xs
dropTrailingSlash [] = []

{- Render a non-effectful in-mount classified 'Route' to a pure response through
the mount's renderer. @\/-\/ping@ is answered locally with @200 {}@;
@\/-\/v1\/search@ is a @501@ pointer; an unrecognised in-mount path is a @404@ --
every error in the mount's own surface. The effectful 'Packument', 'Tarball', and
'Publish' routes are dispatched to the 'Handler' by 'serve' before reaching here;
their branches below are the defensive @501@ fallback should that routing ever change.
-}
renderRoute :: MountRenderer -> Route -> Response
renderRoute :: MountRenderer -> Route -> Response
renderRoute MountRenderer
renderer = \case
    Route
Ping -> Response
pong
    Route
Search -> MountRenderer -> Status -> Text -> Response
renderedError MountRenderer
renderer Status
status501 Text
"search is not supported by this proxy; use the public registry's website to discover packages"
    Packument PackageName
_ -> MountRenderer -> Status -> Text -> Response
renderedError MountRenderer
renderer Status
status501 Text
notYetServedMessage
    Tarball{} -> MountRenderer -> Status -> Text -> Response
renderedError MountRenderer
renderer Status
status501 Text
notYetServedMessage
    Publish PackageName
_ -> MountRenderer -> Status -> Text -> Response
renderedError MountRenderer
renderer Status
status501 Text
notYetServedMessage
    Route
Unsupported -> MountRenderer -> Status -> Text -> Response
renderedError MountRenderer
renderer Status
status404 Text
"not found"
  where
    notYetServedMessage :: Text
    notYetServedMessage :: Text
notYetServedMessage = Text
"this route is recognised but not yet served by this proxy"

-- An in-mount error response: the status, with the body shaped by the mount's
-- renderer. A meta-route error carries no operator help message.
renderedError :: MountRenderer -> Status -> Text -> Response
renderedError :: MountRenderer -> Status -> Text -> Response
renderedError MountRenderer
renderer Status
status Text
message =
    let RenderedBody ByteString
contentType ByteString
body = MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer Maybe HelpMessage
forall a. Maybe a
Nothing Text
message
     in Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status [(HeaderName
hContentType, ByteString
contentType)] ByteString
body

{- @\/-\/ping@: answered locally with @200 {}@, since the client is only
checking that the proxy endpoint it talks to is up. No upstream round-trip.
-}
pong :: Response
pong :: Response
pong = Status -> ByteString -> Response
jsonResponse Status
status200 ByteString
"{}"

{- 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"

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\/hosting.md@ → "Graceful rollover").

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 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")]

{- | The cross-cutting middleware stack composed around the proxy 'Application': a
defensive request-body size cap (rejecting an over-cap body with @413@ once a
handler reads it), correct client-IP recovery behind a load balancer
(@X-Forwarded-For@ \/ @X-Real-IP@), and a per-request timeout.

A fourth middleware, the __going-away__ header, is active only during a graceful
drain: while the 'ServerConfig''s 'DrainSignal' is raised it stamps @Connection:
close@ on every response so an HTTP\/1.1 keep-alive pool (a client's, or a service
mesh's connection pool) does not reuse a socket on an instance that is shutting down
-- the cause of the 503-on-rollover this guards against (see
@docs\/architecture\/hosting.md@ → "Graceful rollover").

Two @wai-extra@ middlewares are deliberately __not__ used. @Autohead@ answers a
HEAD by running the GET handler and discarding the body, which on a tarball route
would open the upstream and stream a whole artifact to nowhere; instead a HEAD on the
tarball or packument route is handled explicitly (in 'serve'), gating exactly as the
GET path does but suppressing the body -- the tarball probing the upstream as a HEAD so
a bodiless HEAD can never trigger a full-artifact upstream fetch, the packument
emitting the same status and headers as the GET with the locally-built body withheld.
@Gzip@
would re-compress already compressed artifacts and fight the streaming backpressure
the serve path relies on.
-}
serverMiddleware :: ServerConfig -> Middleware
serverMiddleware :: ServerConfig -> Middleware
serverMiddleware ServerConfig
cfg =
    RequestSizeLimit -> Middleware
sizeLimitMiddleware (ServerConfig -> RequestSizeLimit
scSizeLimit ServerConfig
cfg)
        Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware
realIp
        Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Middleware
timeout Int
timeoutSeconds
        Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrainSignal -> Middleware
goingAwayMiddleware (ServerConfig -> DrainSignal
scDrain ServerConfig
cfg)

{- 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

-- Cap the request body at the configured limit, rejecting an over-cap body
-- before it is buffered.
sizeLimitMiddleware :: RequestSizeLimit -> Middleware
sizeLimitMiddleware :: RequestSizeLimit -> Middleware
sizeLimitMiddleware (RequestSizeLimit Word64
maxBytes) =
    RequestSizeLimitSettings -> Middleware
requestSizeLimitMiddleware
        ((Request -> IO (Maybe Word64))
-> RequestSizeLimitSettings -> RequestSizeLimitSettings
setMaxLengthForRequest (\Request
_req -> Maybe Word64 -> IO (Maybe Word64)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
maxBytes)) RequestSizeLimitSettings
defaultRequestSizeLimitSettings)

{- | Serve the proxy's HTTP front door: start @warp@ on the 'ServerConfig''s port
with the 'application' built over it and the composition-root 'Env'. The
'ServerConfig' -- in particular its mount bindings ('scMounts'), each a mount's
complete ecosystem wiring -- is supplied by the composition root, which is where the
served ecosystems are mounted (see "Ecluse").

__Graceful shutdown.__ A fresh live 'DrainSignal' is allocated per launch and wired
into both the request path (the @application@ reads it through 'scDrain') and the
@warp@ shutdown handler. On @SIGTERM@ or @SIGINT@ the handler raises the drain -- so
the readiness probe begins failing and responses gain @Connection: close@ -- then
closes the listen socket, which puts @warp@ into graceful-shutdown mode: it stops
accepting new connections and waits for in-flight requests __and in-progress
artifact streams__ to finish before the process exits, bounded by 'scDrainTimeout'.
The handler is a 'CatchOnce', so a second signal during the drain hard-stops the
server rather than being swallowed.

__Local-dev quit key.__ The whole run is wrapped in 'withInteractiveHalt', which --
__only when attached to an interactive terminal__ -- arms a watcher that forces an
immediate halt on Ctrl-D (end of standard input), bypassing the drain like a second
Ctrl-C. Outside a TTY (production) no watcher is installed and this changes nothing.
-}
runWarp :: ServerConfig -> IO Application -> IO ()
runWarp :: ServerConfig -> IO Application -> IO ()
runWarp ServerConfig
cfg0 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
forall a b. (a -> b) -> a -> b
$ Settings
Warp.defaultSettings
    app <- getApp
    withInteractiveHalt defaultInteractiveHalt (Warp.runSettings settings app)

{- Install the OS shutdown handler @warp@ asks for: on @SIGTERM@\/@SIGINT@, raise the
drain (flip readiness to @503@ and start stamping @Connection: close@) and then run
@warp@'s @closeSocket@, which begins the graceful drain of in-flight work. Each
signal is caught __once__ ('CatchOnce') so a second signal falls through to the
runtime's default and hard-stops a drain that is taking too long.
-}
installShutdownHandler :: DrainSignal -> IO () -> IO ()
installShutdownHandler :: DrainSignal -> IO () -> IO ()
installShutdownHandler DrainSignal
drain IO ()
closeSocket =
    (Signal -> IO Handler) -> [Signal] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Signal -> IO Handler
install [Signal
sigTERM, Signal
sigINT]
  where
    install :: Signal -> IO Handler
install Signal
sig = Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sig (IO () -> Handler
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