-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE ExistentialQuantification #-}

{- | Per-request mount wiring, runtime capabilities, and the serve handler monad.
Dispatch pairs one 'MountBinding' with 'ServeRuntime' and establishes the ambient
@katip@ context. The composition root supplies the runtime capabilities.
-}
module Ecluse.Core.Server.Context (
    -- * Request runtime
    ServeRuntime (..),

    -- * Packument-serve dependencies
    PackumentDeps (..),
    pdPrivateBaseUrl,
    pdPublicBaseUrl,
    pdMirror,
    pdTarballHostGate,
    tarballHostHonoured,

    -- * Publish-serve dependencies
    PublishDeps (..),

    -- * The serve action, and the router an adapter supplies
    RouteAction (..),
    ResponseAction (..),
    MountRouter,

    -- * Mount binding
    MountBinding (..),

    -- * Per-request context
    RequestCtx (..),

    -- * The handler monad
    Handler,
    runHandler,
) where

import Data.IP (IPRange)
import Data.Time (UTCTime)
import Katip (Katip, KatipContext, LogEnv, SimpleLogPayload)
import Katip.Monadic (KatipContextT, runKatipContextT)
import Network.HTTP.Client (Manager)
import Network.HTTP.Types (Method)
import Network.HTTP.Types.Header (RequestHeaders)
import Network.Wai (ResponseReceived)
import Network.Wai qualified as Wai
import UnliftIO (MonadUnliftIO)

import Ecluse.Core.Credential (Secret)
import Ecluse.Core.Cve.Types (DbEtag)
import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Package.Integrity (MinIntegrity, MinTrustedIntegrity)
import Ecluse.Core.Queue (MirrorQueue)
import Ecluse.Core.Registry.Adapter.Capability (AdapterArtifact, AdapterMetadata, AdapterPublish, ProjectName)
import Ecluse.Core.Registry.Request (CredentialMapping)
import Ecluse.Core.Rules (PreparedRule)
import Ecluse.Core.Rules.Outage (AdmissionIdentity)
import Ecluse.Core.Security (HostPort, Limits, Origin, TarballHostGate, tarballHostAllowed, thgAllowlist, thgEcosystemHosts)
import Ecluse.Core.Security.Egress (RegistryUrl)
import Ecluse.Core.Server.Admission (ServeAdmission)
import Ecluse.Core.Server.Admission.Bytes (ByteAdmission)
import Ecluse.Core.Server.Admission.Meter (MemoryMeter)
import Ecluse.Core.Server.Cache (MetadataCache)
import Ecluse.Core.Server.Contract (ResponseContract)
import Ecluse.Core.Server.Response (HelpMessage)
import Ecluse.Core.Server.Upstream (
    MirrorServePlan,
    MountUpstreams,
    upstreamMirror,
    upstreamPrivateBaseUrl,
    upstreamPublicBaseUrl,
    upstreamTarballHostGate,
 )
import Ecluse.Core.Telemetry.Record (MetricsPort)
import Ecluse.Core.Telemetry.Span (TracingPort)

-- | Serve capabilities assembled at boot. Both HTTP managers must validate TLS certificates.
data ServeRuntime = ServeRuntime
    { ServeRuntime -> ServeAdmission
srAdmission :: ServeAdmission
    -- ^ Bounds concurrent metadata work, excluding private artifact reads and artifact relay.
    , ServeRuntime -> MemoryMeter
srMemoryMeter :: MemoryMeter
    -- ^ The memory budget metadata requests pay into as they read and build.
    , ServeRuntime -> Manager
srPublicManager :: Manager
    {- ^ The validating-TLS data-plane manager for the __untrusted__ public-upstream
    metadata fetch and every artifact stream.
    -}
    , ServeRuntime -> Manager
srPrivateManager :: Manager
    {- ^ The manager for the __trusted__ private upstream. It is the same validating TLS
    manager: the private origin differs in credential handling, not in the manager.
    -}
    , ServeRuntime -> MetadataCache
srMetadataCache :: MetadataCache
    {- ^ The short-TTL, size-bounded metadata cache shared by the serve paths
    (see "Ecluse.Core.Server.Cache").
    -}
    , ServeRuntime -> MirrorQueue
srQueue :: MirrorQueue
    {- ^ The mirror-queue handle: the durable, best-effort hand-off from the serve
    path to the mirror worker.
    -}
    , ServeRuntime -> MetricsPort
srMetrics :: MetricsPort
    -- ^ The metric-recording port the serve path emits the @ecluse.*@ catalogue through.
    , ServeRuntime -> TracingPort
srTracing :: TracingPort
    -- ^ The tracing port the serve path opens its hand-added domain spans through.
    }

-- | Mount inputs shared by packument and tarball handlers, resolved at boot.
data PackumentDeps = PackumentDeps
    { PackumentDeps -> MountUpstreams
pdUpstreams :: MountUpstreams
    -- ^ Upstreams bound to their derived host gate, so their authorities cannot diverge.
    , PackumentDeps -> PackageName -> Bool
pdFirstParty :: PackageName -> Bool
    {- ^ Whether a name belongs to a namespace this deployment owns, derived once at the composition root and deny
    by default. Its one authority is the private upstream: the public leg is never entered, and a private miss is @404@.
    -}
    , PackumentDeps -> Text
pdMountBaseUrl :: Text
    {- ^ The mount's externally-visible base URL, under which served @dist.tarball@
    URLs are rewritten so artifacts are fetched back through the gate.
    -}
    , PackumentDeps -> [PreparedRule]
pdRules :: [PreparedRule]
    -- ^ Rules prepared at boot and evaluated against every public version.
    , PackumentDeps -> [IPRange]
pdAdditionalBlockedRanges :: [IPRange]
    -- ^ Extra blocked IP ranges for untrusted artifact locations. Empty by default.
    , PackumentDeps -> Limits
pdLimits :: Limits
    -- ^ Fetch and decode limits. A breach discards the whole upstream contribution.
    , PackumentDeps -> Maybe Secret
pdInboundToken :: Maybe Secret
    {- ^ The optional inbound token a client must present (@ECLUSE_SERVER__AUTH_TOKEN@).
    'Nothing' leaves the edge open, and the network layer guards it.
    -}
    , PackumentDeps -> IO UTCTime
pdNow :: IO UTCTime
    {- ^ The wall-clock "now" for the rules' 'Ecluse.Core.Rules.Types.EvalContext'.
    Injected so the time-sensitive quarantine is deterministic under test.
    -}
    , PackumentDeps -> IO (Maybe DbEtag)
pdAdvisoryEtag :: IO (Maybe DbEtag)
    -- ^ Non-pinning read of the active advisory etag. 'Nothing' means no database is loaded.
    , PackumentDeps -> AdmissionIdentity -> IO Bool
pdNoteAdmission :: AdmissionIdentity -> IO Bool
    {- ^ Whether the gate logs an admission's skipped-check evidence, once per identity for the
    life of the advisory source's outage ('Ecluse.Core.Rules.Outage.noteAdmission').
    -}
    , PackumentDeps -> Maybe HelpMessage
pdHelp :: Maybe HelpMessage
    -- ^ The operator help message appended to every denial body, if configured.
    , PackumentDeps -> MinIntegrity
pdMinIntegrity :: MinIntegrity
    -- ^ Public integrity floor, at least SHA-256. Private reads use 'pdMinTrustedIntegrity'.
    , PackumentDeps -> MinTrustedIntegrity
pdMinTrustedIntegrity :: MinTrustedIntegrity
    -- ^ The minimum integrity hash required for a trusted upstream dependency.
    , PackumentDeps -> AdapterMetadata
pdMetadata :: AdapterMetadata
    {- ^ The mount ecosystem's metadata capability, carried whole
    ('Ecluse.Core.Registry.Adapter.Capability.AdapterMetadata'), never copied field by field.
    -}
    , PackumentDeps -> AdapterArtifact
pdArtifact :: AdapterArtifact
    {- ^ The mount ecosystem's artifact request formation, carried whole
    ('Ecluse.Core.Registry.Adapter.Capability.AdapterArtifact'), never copied field by field.
    -}
    , PackumentDeps -> Text -> Either Text RegistryUrl
pdEgressUrl :: Text -> Either Text RegistryUrl
    -- ^ Validate an artifact URL before enqueueing it. A 'Left' prevents the mirror job.
    }

-- | The private URL bound to the host gate. 'Nothing' skips the private fetch.
pdPrivateBaseUrl :: PackumentDeps -> Maybe RegistryUrl
pdPrivateBaseUrl :: PackumentDeps -> Maybe RegistryUrl
pdPrivateBaseUrl = MountUpstreams -> Maybe RegistryUrl
upstreamPrivateBaseUrl (MountUpstreams -> Maybe RegistryUrl)
-> (PackumentDeps -> MountUpstreams)
-> PackumentDeps
-> Maybe RegistryUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackumentDeps -> MountUpstreams
pdUpstreams

-- | The public upstream base URL. Reads are anonymous, with no client credential.
pdPublicBaseUrl :: PackumentDeps -> RegistryUrl
pdPublicBaseUrl :: PackumentDeps -> RegistryUrl
pdPublicBaseUrl = MountUpstreams -> RegistryUrl
upstreamPublicBaseUrl (MountUpstreams -> RegistryUrl)
-> (PackumentDeps -> MountUpstreams)
-> PackumentDeps
-> RegistryUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackumentDeps -> MountUpstreams
pdUpstreams

-- | The mirror destination for admitted public artifacts, or no write for a serve-only mount.
pdMirror :: PackumentDeps -> MirrorServePlan
pdMirror :: PackumentDeps -> MirrorServePlan
pdMirror = MountUpstreams -> MirrorServePlan
upstreamMirror (MountUpstreams -> MirrorServePlan)
-> (PackumentDeps -> MountUpstreams)
-> PackumentDeps
-> MirrorServePlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackumentDeps -> MountUpstreams
pdUpstreams

-- | The host gate derived from the mount's upstreams at boot.
pdTarballHostGate :: PackumentDeps -> TarballHostGate
pdTarballHostGate :: PackumentDeps -> TarballHostGate
pdTarballHostGate = MountUpstreams -> TarballHostGate
upstreamTarballHostGate (MountUpstreams -> TarballHostGate)
-> (PackumentDeps -> MountUpstreams)
-> PackumentDeps
-> TarballHostGate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackumentDeps -> MountUpstreams
pdUpstreams

{- | Apply 'tarballHostAllowed' with this mount's inputs for both serving and mirror re-evaluation.
A missing authority refuses. Trusted origins bypass only the internal-range block.
-}
tarballHostHonoured :: Origin -> PackumentDeps -> Maybe HostPort -> Maybe HostPort -> Bool
tarballHostHonoured :: Origin -> PackumentDeps -> Maybe HostPort -> Maybe HostPort -> Bool
tarballHostHonoured Origin
origin PackumentDeps
deps =
    AllowedHostPorts
-> Origin
-> AllowedHostPorts
-> [IPRange]
-> Maybe HostPort
-> Maybe HostPort
-> Bool
tarballHostAllowed
        (TarballHostGate -> AllowedHostPorts
thgEcosystemHosts (PackumentDeps -> TarballHostGate
pdTarballHostGate PackumentDeps
deps))
        Origin
origin
        (TarballHostGate -> AllowedHostPorts
thgAllowlist (PackumentDeps -> TarballHostGate
pdTarballHostGate PackumentDeps
deps))
        (PackumentDeps -> [IPRange]
pdAdditionalBlockedRanges PackumentDeps
deps)

-- | First-party publish inputs. Their presence enables the mount's publish route.
data PublishDeps = PublishDeps
    { PublishDeps -> RegistryUrl
pubTargetUrl :: RegistryUrl
    {- ^ The publication target endpoint (@mounts.npm.publicationTarget@) a client
    @npm publish@ is relayed to, as the https-only witness. The package path is appended to it.
    -}
    , PublishDeps -> PackageName -> Bool
pubAllowed :: PackageName -> Bool
    {- ^ Whether this package may publish here, refused before any upstream write: the same
    first-party predicate the serve path reads as 'pdFirstParty'.
    -}
    , PublishDeps -> Maybe Secret
pubStaticToken :: Maybe Secret
    -- ^ Replaces the authenticated edge token on publishes. Requires 'pubInboundToken' at boot.
    , PublishDeps -> Maybe Secret
pubInboundToken :: Maybe Secret
    {- ^ The optional inbound edge token a client must present (@ECLUSE_SERVER__AUTH_TOKEN@),
    the same gate the read paths apply. 'Nothing' leaves the edge open.
    -}
    , PublishDeps -> Limits
pubLimits :: Limits
    -- ^ Separate client request and registry response bounds for publication.
    , PublishDeps -> ByteAdmission
pubBodyBudget :: ByteAdmission
    -- ^ Shared body-byte budget reserved before reading. Exhaustion sheds a @503@.
    , PublishDeps -> Maybe HelpMessage
pubHelp :: Maybe HelpMessage
    -- ^ The operator help message appended to a publish denial, if configured.
    , PublishDeps -> ProjectName
pubProjectName :: ProjectName
    -- ^ The ecosystem's own name parser, which the anti-shadowing guard reads a declared name through.
    , PublishDeps -> AdapterPublish
pubAdapter :: AdapterPublish
    {- ^ The mount ecosystem's publish capability, carried whole
    ('Ecluse.Core.Registry.Adapter.Capability.AdapterPublish'), never copied field by field.
    -}
    }

-- | A matched request's action, constrained to its route's response contract.
data ResponseAction response
    = -- | A pure value admitted by the route's response contract.
      AnswerLocally response
    | {- | A refusal the route decided, rendered where the mount's help message is known, so a
      route table carries no configuration of its own.
      -}
      AnswerRefusal (Maybe HelpMessage -> response)
    | -- | A data-plane handler and its pre-commit fallback, both constrained to the route's response type.
      RunPipeline response (Wai.Request -> (response -> IO ResponseReceived) -> Handler ResponseReceived)

{- | A matched route's response contract paired with an action that produces only that contract's
response type. Dispatch renders the action without knowing an ecosystem's response sum.
-}
data RouteAction = forall response. RouteAction (ResponseContract response) (ResponseAction response)

{- | An ecosystem's whole routing decision over a mount-relative request, from its adapter. The
method and the headers are part of the mapping, and segments arrive stripped and decoded.
-}
type MountRouter = Method -> RequestHeaders -> [Text] -> RouteAction

-- | Ecosystem wiring under a non-empty prefix, so adding an ecosystem never displaces a root mount.
data MountBinding = MountBinding
    { MountBinding -> NonEmpty Text
bindingPrefix :: NonEmpty Text
    -- ^ The leading path segments this mount is served under. Never empty.
    , MountBinding -> MountRouter
bindingRouter :: MountRouter
    -- ^ This mount's routing decision, derived from the adapter's own route table.
    , MountBinding -> CredentialMapping
bindingCredential :: CredentialMapping
    {- ^ How a client of this mount presents its credential, and how the proxy carries one
    upstream. The adapter declares it, so the serve path holds no credential scheme of its own.
    -}
    , MountBinding -> PackumentDeps
bindingPackumentDeps :: PackumentDeps
    {- ^ The packument-serve dependencies. A bound mount always serves packuments and artifacts,
    because a mount exists only for a registered adapter. Only /publish/ is opt-in.
    -}
    , MountBinding -> Maybe PublishDeps
bindingPublishDeps :: Maybe PublishDeps
    -- ^ Optional first-party publish dependencies. 'Nothing' makes @PUT \/{pkg}@ answer @405@.
    }

{- | The context one request is served through: the request runtime paired with the 'MountBinding'
the request matched. Dispatch builds it once per request, and 'Handler' reads it through its reader.
-}
data RequestCtx = RequestCtx
    { RequestCtx -> ServeRuntime
ctxRuntime :: ServeRuntime
    {- ^ The request runtime: the data-plane managers, the caches and queue, and the
    recording ports.
    -}
    , RequestCtx -> MountBinding
ctxMount :: MountBinding
    -- ^ The mount the request matched, carrying its complete ecosystem wiring.
    }

-- | Request context over @katip@'s reader-based logging context, shared across concurrent fetches.
newtype Handler a = Handler
    { forall a. Handler a -> ReaderT RequestCtx (KatipContextT IO) a
unHandler :: ReaderT RequestCtx (KatipContextT IO) a
    }
    deriving newtype
        ( (forall a b. (a -> b) -> Handler a -> Handler b)
-> (forall a b. a -> Handler b -> Handler a) -> Functor Handler
forall a b. a -> Handler b -> Handler a
forall a b. (a -> b) -> Handler a -> Handler b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Handler a -> Handler b
fmap :: forall a b. (a -> b) -> Handler a -> Handler b
$c<$ :: forall a b. a -> Handler b -> Handler a
<$ :: forall a b. a -> Handler b -> Handler a
Functor
        , Functor Handler
Functor Handler =>
(forall a. a -> Handler a)
-> (forall a b. Handler (a -> b) -> Handler a -> Handler b)
-> (forall a b c.
    (a -> b -> c) -> Handler a -> Handler b -> Handler c)
-> (forall a b. Handler a -> Handler b -> Handler b)
-> (forall a b. Handler a -> Handler b -> Handler a)
-> Applicative Handler
forall a. a -> Handler a
forall a b. Handler a -> Handler b -> Handler a
forall a b. Handler a -> Handler b -> Handler b
forall a b. Handler (a -> b) -> Handler a -> Handler b
forall a b c. (a -> b -> c) -> Handler a -> Handler b -> Handler c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Handler a
pure :: forall a. a -> Handler a
$c<*> :: forall a b. Handler (a -> b) -> Handler a -> Handler b
<*> :: forall a b. Handler (a -> b) -> Handler a -> Handler b
$cliftA2 :: forall a b c. (a -> b -> c) -> Handler a -> Handler b -> Handler c
liftA2 :: forall a b c. (a -> b -> c) -> Handler a -> Handler b -> Handler c
$c*> :: forall a b. Handler a -> Handler b -> Handler b
*> :: forall a b. Handler a -> Handler b -> Handler b
$c<* :: forall a b. Handler a -> Handler b -> Handler a
<* :: forall a b. Handler a -> Handler b -> Handler a
Applicative
        , Applicative Handler
Applicative Handler =>
(forall a b. Handler a -> (a -> Handler b) -> Handler b)
-> (forall a b. Handler a -> Handler b -> Handler b)
-> (forall a. a -> Handler a)
-> Monad Handler
forall a. a -> Handler a
forall a b. Handler a -> Handler b -> Handler b
forall a b. Handler a -> (a -> Handler b) -> Handler b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Handler a -> (a -> Handler b) -> Handler b
>>= :: forall a b. Handler a -> (a -> Handler b) -> Handler b
$c>> :: forall a b. Handler a -> Handler b -> Handler b
>> :: forall a b. Handler a -> Handler b -> Handler b
$creturn :: forall a. a -> Handler a
return :: forall a. a -> Handler a
Monad
        , Monad Handler
Monad Handler => (forall a. IO a -> Handler a) -> MonadIO Handler
forall a. IO a -> Handler a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Handler a
liftIO :: forall a. IO a -> Handler a
MonadIO
        , MonadReader RequestCtx
        , MonadIO Handler
MonadIO Handler =>
(forall b. ((forall a. Handler a -> IO a) -> IO b) -> Handler b)
-> MonadUnliftIO Handler
forall b. ((forall a. Handler a -> IO a) -> IO b) -> Handler b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b. ((forall a. Handler a -> IO a) -> IO b) -> Handler b
withRunInIO :: forall b. ((forall a. Handler a -> IO a) -> IO b) -> Handler b
MonadUnliftIO
        , MonadIO Handler
Handler LogEnv
MonadIO Handler =>
Handler LogEnv
-> (forall a. (LogEnv -> LogEnv) -> Handler a -> Handler a)
-> Katip Handler
forall a. (LogEnv -> LogEnv) -> Handler a -> Handler a
forall (m :: * -> *).
MonadIO m =>
m LogEnv -> (forall a. (LogEnv -> LogEnv) -> m a -> m a) -> Katip m
$cgetLogEnv :: Handler LogEnv
getLogEnv :: Handler LogEnv
$clocalLogEnv :: forall a. (LogEnv -> LogEnv) -> Handler a -> Handler a
localLogEnv :: forall a. (LogEnv -> LogEnv) -> Handler a -> Handler a
Katip
        , Katip Handler
Handler Namespace
Handler LogContexts
Katip Handler =>
Handler LogContexts
-> (forall a.
    (LogContexts -> LogContexts) -> Handler a -> Handler a)
-> Handler Namespace
-> (forall a. (Namespace -> Namespace) -> Handler a -> Handler a)
-> KatipContext Handler
forall a. (Namespace -> Namespace) -> Handler a -> Handler a
forall a. (LogContexts -> LogContexts) -> Handler a -> Handler a
forall (m :: * -> *).
Katip m =>
m LogContexts
-> (forall a. (LogContexts -> LogContexts) -> m a -> m a)
-> m Namespace
-> (forall a. (Namespace -> Namespace) -> m a -> m a)
-> KatipContext m
$cgetKatipContext :: Handler LogContexts
getKatipContext :: Handler LogContexts
$clocalKatipContext :: forall a. (LogContexts -> LogContexts) -> Handler a -> Handler a
localKatipContext :: forall a. (LogContexts -> LogContexts) -> Handler a -> Handler a
$cgetKatipNamespace :: Handler Namespace
getKatipNamespace :: Handler Namespace
$clocalKatipNamespace :: forall a. (Namespace -> Namespace) -> Handler a -> Handler a
localKatipNamespace :: forall a. (Namespace -> Namespace) -> Handler a -> Handler a
KatipContext
        )

-- | Run a handler with the application's log stream and initial trace-correlation payload.
runHandler :: LogEnv -> SimpleLogPayload -> RequestCtx -> Handler a -> IO a
runHandler :: forall a.
LogEnv -> SimpleLogPayload -> RequestCtx -> Handler a -> IO a
runHandler LogEnv
logEnv SimpleLogPayload
initialContext RequestCtx
ctx Handler a
action =
    LogEnv
-> SimpleLogPayload -> Namespace -> KatipContextT IO a -> IO a
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv SimpleLogPayload
initialContext Namespace
forall a. Monoid a => a
mempty (ReaderT RequestCtx (KatipContextT IO) a
-> RequestCtx -> KatipContextT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Handler a -> ReaderT RequestCtx (KatipContextT IO) a
forall a. Handler a -> ReaderT RequestCtx (KatipContextT IO) a
unHandler Handler a
action) RequestCtx
ctx)