{- | The serve paths behind the package routes: the artifact relay behind @GET \/{pkg}\/-\/{file}.tgz@.

This is the data-plane handler module for artifacts. It composes the
slices that decide /what/ to serve into one action in the
'Ecluse.Core.Server.Context.Handler' reader, reading its mount's serve dependencies and
the request runtime 'Ecluse.Core.Server.Context.ServeRuntime' from the request's
'Ecluse.Core.Server.Context.RequestCtx'.

== Artifact path

The tarball handler ('serveTarball') is the demand-driven artifact relay. Its two legs
locate the tarball differently, by the trust of their origin.

The __private__ leg is a __conventional stable read__: it fetches the tarball at
@{pdPrivateBaseUrl}\/{pkg}\/-\/{file}@ ('artifactRequestByFile'), addressed by the
client's requested filename, __without a private-packument fetch__ -- the stable,
cacheable shape an @npm ci@ install issues, so a worst-case lockfile fan-out pays one
artifact round-trip per tarball rather than a packument fetch+decode per tarball it
would only discard. The request __forwards the client's credential__ over the
__trusted__ manager, attached at the single bearer-attach point
('Ecluse.Core.Registry.Npm.withToken'), which pins @redirectCount = 0@: this
credential-bearing read __never follows a redirect__ (a private CDN @302@ is returned to
the serve path, not chased with the bearer). The constructed URL is on the private base
host, so the 'Ecluse.Core.Security.TrustedOrigin' tarball-host gate is satisfied
__same-host__, and the trusted origin is exempt from the internal-range block (a private
registry on an internal address still serves). A @2xx@ streams the artifact through with
__bounded memory__ (the @withResponse@\/@responseStream@ relay, never a buffering fetch)
and __answers the request__; a non-@2xx@ status or a connection failure is a __clean
miss__ that falls through to the public leg.

The private leg applies __no serve-time integrity floor__. An established version pinned
in a consumer's lockfile and served from an operator-__trusted__ private registry is
fast-tracked: its bytes are still verified __client-side by @npm@__ (against the
@dist.integrity@ it resolved over the packument route) and by the __mirror worker__ on
ingestion, so fast-tracking gives up only the proactive "refuse weak-integrity" stance,
not tamper-evidence. A consequence of the conventional read: a private upstream that
serves its tarball __off the conventional @\/-\/@ path__ (a separate files host, a signed
CDN URL the convention cannot rebuild) is not reached by this leg, so it is a private
miss that falls through to the public origin.

The __public__ leg honours the __authoritative upstream location__ -- the
@Artifact.artUrl@ the projection preserved from the gated version's @dist.tarball@,
selected by the requested filename -- rather than reconstructing the conventional path,
so the proxy can front a public registry that serves its artifacts from a separate host
or an off-convention path (a CDN\/files host, a signed URL). That location is gated, not
trusted: it is fetched only when the tarball-host policy
('Ecluse.Core.Security.tarballHostAllowed', per @ECLUSE_RESPECT_UPSTREAM_TARBALL_HOST@)
admits its host (the default refuses a cross-host @dist.tarball@), and the untrusted
egress is https-only with certificate validation. The public leg is anonymous: it
gates __that one version__ against the rules (the same machinery the packument path
gates the whole set with) and selects the artifact, and on an admit __streams the public
bytes from @artUrl@ and enqueues a 'Ecluse.Core.Queue.MirrorJob'__ (naming that
authoritative URL) for the worker to back-fill the mirror target; on a reject --
including a host the tarball-host policy refuses -- it renders the serve error model
(@403@\/@503@\/@500@\/@404@) through the mount's renderer. The enqueue is
__serve-then-enqueue, best-effort and non-blocking__: the artifact reaches the client
first, and an enqueue failure is swallowed rather than failing or delaying the response.
Mirroring is __demand-driven__ -- a job is enqueued only here, on a tarball-path admit,
never when a packument is filtered. The two legs are not peers over time: the
back-fill retires each artifact from the public leg, so at steady state the private
conventional read serves the vast majority of tarball traffic and the public leg is
the transient onboarding\/fail-over ramp (see
@docs\/architecture\/registry-model.md@ → "Traffic shape over time"). The serve path does __not__ verify @dist.integrity@;
the client checks the artifact's own hash and the worker re-verifies before publishing.

An artifact is a __pass-through__ body -- served byte-identical to upstream's -- so its
conditional-GET handling __relays__ rather than computing an own ETag (see
@docs\/architecture\/web-layer.md@ → "Middleware and helper libraries", and contrast
the merged-packument own-ETag path): the client's @If-None-Match@\/@If-Modified-Since@
are forwarded onto the upstream artifact request on __both__ legs ('forwardValidators'),
and an upstream @304 Not Modified@ is relayed straight back to the client as a bodiless
@304@ ('isNotModified' via the relay's accept predicate) rather than re-downloading the
tarball -- the cheap freshness check on the hot artifact path.
-}
module Ecluse.Core.Server.Pipeline.Tarball (
    -- * The tarball handler
    serveTarball,
    headTarball,
) where

import Network.HTTP.Client (Manager)
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Types (RequestHeaders, ResponseHeaders, Status, hContentType, methodHead, mkStatus, statusIsSuccessful)
import Network.Wai (Request, Response, ResponseReceived, requestHeaders, responseLBS)
import UnliftIO.Exception (tryAny)

import Ecluse.Core.Credential (Secret)
import Ecluse.Core.Package (
    Artifact (artFilename, artHashes, artSize, artUrl),
    PackageDetails (pkgArtifacts),
    PackageName,
 )
import Ecluse.Core.Package.Integrity (
    VersionIntegrity (BelowFloor, MeetsFloor, NoIntegrity),
    classifyArtifacts,
 )
import Ecluse.Core.Queue (
    MirrorArtifact (MirrorArtifact, maFilename, maHashes, maSize),
    MirrorJob (MirrorJob, jobArtifact, jobArtifactUrl, jobMirrorTarget, jobPackage, jobTraceContext, jobVersion),
    enqueue,
 )
import Ecluse.Core.Registry.Metadata (
    VersionEvaluation (VersionMetadataUnavailable, VersionMissing, VersionPresent),
    fetchVersionDetails,
 )
import Ecluse.Core.Rules (evalRules)
import Ecluse.Core.Rules.Types (EvalContext (EvalContext))
import Ecluse.Core.Security (
    Origin (TrustedOrigin, UntrustedOrigin),
    hostAddress,
    tarballHostAllowed,
    thgAllowlist,
    thgPrivateHost,
    thgPublicHost,
 )
import Ecluse.Core.Server.Admission (withServeAdmission)
import Ecluse.Core.Server.Conditional (forwardValidators, isNotModified)
import Ecluse.Core.Server.Context (
    Handler,
    MountBinding (bindingPackumentDeps, bindingRenderer),
    PackumentDeps (..),
    ServeRuntime (..),
    ctxMount,
    ctxRuntime,
 )
import Ecluse.Core.Server.Pipeline.Internal (
    evalTier,
    recordDenials,
    serveDecisionClass,
 )
import Ecluse.Core.Server.Pipeline.Packument (withPublicMetadataClient)
import Ecluse.Core.Server.Pipeline.Shared
import Ecluse.Core.Server.Response (
    ArtifactStatus (Forbidden, NotFound, Ok, ServerError, Unavailable'),
    MountRenderer,
    RejectReason (Unavailable),
    Rejection (Rejection, rejectionMessage),
    RetryAfter (..),
    ServeDecision (Admit, Reject),
    Transience (WillResolve, WontResolve),
    artifactStatus,
    artifactStatusCode,
    renderError,
    serveDecisionOf,
 )
import Ecluse.Core.Server.Route (Filename (Filename))
import Ecluse.Core.Server.Stream (probeUpstreamWhen, streamUpstreamWhen)
import Ecluse.Core.Telemetry.Metrics qualified as Metric
import Ecluse.Core.Telemetry.Record (MetricsPort (..), timedSeconds)
import Ecluse.Core.Telemetry.Span (spanMirrorEnqueue, spanRuleEval)
import Ecluse.Core.Version (Version)

{- | Serve a @GET \/{pkg}\/-\/{file}.tgz@ artifact request end to end, over the
request's 'RequestCtx'.

The mount's 'PackumentDeps' and error renderer are read from the matched
'MountBinding'; an unwired mount is the recognised-but-unserved @501@ stub (as for
'servePackument'). With dependencies wired and the edge token (if any) validated, the
two legs locate the tarball by the trust of their origin:

* the __private__ leg is a __conventional stable read__: it fetches
  @{pdPrivateBaseUrl}\/{pkg}\/-\/{file}@ by the requested filename
  ('artifactRequestByFile'), __forwarding the client's credential__ and __without a
  private-packument fetch__; a @2xx@ streams the bytes through with bounded memory and
  answers the request, any other status (or a connection failure) is a clean miss that
  falls through. It applies no serve-time integrity floor -- the bytes are still verified
  client-side and by the mirror worker (see the module header → "Artifact path");
* on a private miss the __public__ leg fetches that one version's metadata anonymously
  and gates it against the rules; an admit honours the gated @dist.tarball@, streaming
  the public bytes __and enqueuing a 'MirrorJob'__ (serve-then-enqueue, the enqueue
  best-effort and non-blocking), a reject renders the serve error model
  (@403@\/@503@\/@500@\/@404@) through the mount's renderer.

The public-upstream fetch is always anonymous (the client credential is never sent to the
public upstream); the mirror job carries no credential. The serve path does not
verify @dist.integrity@ (see the module header → "Artifact path").
-}
serveTarball ::
    PackageName ->
    Version ->
    Filename ->
    Request ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
serveTarball :: PackageName
-> Version
-> Filename
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
serveTarball = ArtifactServe
-> PackageName
-> Version
-> Filename
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
tarballWith ArtifactServe
ServeFull

{- | Serve a @HEAD \/{pkg}\/-\/{file}.tgz@ artifact request end to end, over the
request's 'RequestCtx'.

A HEAD must __never__ run the full-@GET@ streaming pump: a bodiless HEAD would
otherwise open the upstream artifact connection and pump a whole artifact body that
the reply then discards -- wasted upstream egress and a DoS-amplification lever (a
client forcing arbitrary full-artifact fetches with cheap HEADs). So this handler
gates the artifact through the __identical__ pipeline as 'serveTarball' -- the same
edge auth, host-allowlist, internal-range, and tarball-host policy, and the same
upstream-request construction -- but issues the upstream request as a HEAD and relays
its status and safe response headers ('relayArtifact') with __no body__
('Ecluse.Core.Server.Stream.probeUpstreamWhen'). On an admit no 'MirrorJob' is enqueued: a
HEAD serves no bytes, so there is nothing to back-fill (mirroring stays demand-driven
on the GET path). A refusal renders the same serve error model with an empty body.
-}
headTarball ::
    PackageName ->
    Version ->
    Filename ->
    Request ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
headTarball :: PackageName
-> Version
-> Filename
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
headTarball PackageName
name Version
version Filename
filename Request
request Response -> IO ResponseReceived
respond =
    -- A HEAD reply carries no body, by HTTP semantics: every branch -- the bodiless
    -- upstream probe, an edge 401, a policy 403/404/503, an internal 500 -- answers
    -- through 'bodiless', which keeps each branch's status and headers but strips the
    -- body. (The 'ServeHead' upstream probe is what keeps the artifact body from being
    -- fetched at all; this strips the body of the locally-rendered branches too.)
    ArtifactServe
-> PackageName
-> Version
-> Filename
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
tarballWith ArtifactServe
ServeHead PackageName
name Version
version Filename
filename Request
request (Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (Response -> Response) -> Response -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Response
bodiless)

-- The artifact serve mode: a full GET that streams the body through, or a HEAD that
-- probes the upstream bodiless and relays only the headers. Threaded through the
-- artifact path so the gating and upstream-request construction are shared verbatim
-- between the two, differing only in the upstream method, whether a body is pumped,
-- and whether an admit enqueues a mirror job.
data ArtifactServe
    = -- A GET: stream the artifact body through, enqueuing a mirror job on a public
      -- admit (the demand-driven back-fill).
      ServeFull
    | -- A HEAD: probe the upstream as a HEAD and relay the headers with no body,
      -- enqueuing nothing (no bytes are served, so there is nothing to mirror).
      ServeHead

-- The dispatch shared by 'serveTarball' and 'headTarball': resolve the mount's
-- dependencies (or the recognised-but-unserved @501@ stub) and serve in the given mode.
tarballWith ::
    ArtifactServe ->
    PackageName ->
    Version ->
    Filename ->
    Request ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
tarballWith :: ArtifactServe
-> PackageName
-> Version
-> Filename
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
tarballWith ArtifactServe
mode PackageName
name Version
version Filename
filename Request
request Response -> IO ResponseReceived
respond = do
    renderer <- (RequestCtx -> MountRenderer) -> Handler MountRenderer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (MountBinding -> MountRenderer
bindingRenderer (MountBinding -> MountRenderer)
-> (RequestCtx -> MountBinding) -> RequestCtx -> MountRenderer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestCtx -> MountBinding
ctxMount)
    asks (bindingPackumentDeps . ctxMount) >>= \case
        Maybe PackumentDeps
Nothing -> IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Response -> IO ResponseReceived
respond (MountRenderer -> Response
recognisedButUnserved MountRenderer
renderer))
        Just PackumentDeps
deps -> ArtifactServe
-> MountRenderer
-> PackumentDeps
-> PackageName
-> Version
-> Filename
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
serveTarballWithDeps ArtifactServe
mode MountRenderer
renderer PackumentDeps
deps PackageName
name Version
version Filename
filename Request
request Response -> IO ResponseReceived
respond

-- Serve a tarball once the mount's dependencies are known: edge auth, then the
-- private-hit / public-miss fetches the module header describes. The request runtime
-- is read from the request context. The 'ArtifactServe' mode is threaded into
-- both legs so a HEAD takes the identical gating as a GET, probing bodiless.
serveTarballWithDeps ::
    ArtifactServe ->
    MountRenderer ->
    PackumentDeps ->
    PackageName ->
    Version ->
    Filename ->
    Request ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
serveTarballWithDeps :: ArtifactServe
-> MountRenderer
-> PackumentDeps
-> PackageName
-> Version
-> Filename
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
serveTarballWithDeps ArtifactServe
mode MountRenderer
renderer PackumentDeps
deps PackageName
name Version
version (Filename Text
file) Request
request Response -> IO ResponseReceived
respond
    | Bool -> Bool
not (Maybe Secret -> Maybe Secret -> Bool
edgeTokenMatches (PackumentDeps -> Maybe Secret
pdInboundToken PackumentDeps
deps) Maybe Secret
clientToken) = IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Response -> IO ResponseReceived
respond (MountRenderer -> Response
edgeUnauthorised MountRenderer
renderer))
    | Bool
otherwise = do
        rt <- (RequestCtx -> ServeRuntime) -> Handler ServeRuntime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestCtx -> ServeRuntime
ctxRuntime
        -- The client's conditional validators, relayed onto the upstream
        -- artifact request on both legs so upstream can answer a 304 for a
        -- pass-through body we serve unchanged (the conditional-GET contract).
        let validators = RequestHeaders -> RequestHeaders
forwardValidators (Request -> RequestHeaders
requestHeaders Request
request)
        privateHit <- streamPrivateArtifact mode rt deps clientToken validators name file respond
        case privateHit of
            Just ResponseReceived
received -> do
                -- A private hit is an admit served from the trusted upstream (no rule
                -- gate runs); a private miss falls through to the gated public path,
                -- which records its own decision.
                IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> Decision -> IO ()
mpServeDecision (ServeRuntime -> MetricsPort
srMetrics ServeRuntime
rt) Decision
Metric.Admit)
                ResponseReceived -> Handler ResponseReceived
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
received
            Maybe ResponseReceived
Nothing -> ArtifactServe
-> ServeRuntime
-> MountRenderer
-> PackumentDeps
-> RequestHeaders
-> PackageName
-> Version
-> Text
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
servePublicArtifact ArtifactServe
mode ServeRuntime
rt MountRenderer
renderer PackumentDeps
deps RequestHeaders
validators PackageName
name Version
version Text
file Response -> IO ResponseReceived
respond
  where
    -- The client's bearer, scanned out of the headers once: the edge gate compares
    -- it and the private leg forwards it.
    clientToken :: Maybe Secret
clientToken = Request -> Maybe Secret
forwardedToken Request
request

{- Stream the artifact from the __trusted__ private upstream as a __conventional stable
read__: build the tarball request at @{pdPrivateBaseUrl}\/{pkg}\/-\/{file}@ by the
client's requested filename ('artifactRequestByFile') and fetch it directly, __without
fetching the private packument first__. This is the stable, cacheable shape an @npm ci@
install issues; a worst-case lockfile fan-out therefore pays one artifact round-trip per
tarball rather than an uncached packument fetch+decode it would only discard.

The request __forwards the client's credential__ over the trusted manager, attached at
the single bearer-attach point ('Ecluse.Core.Registry.Npm.withToken'), which pins
@redirectCount = 0@: the credential-bearing read __never follows a redirect__ (a private
CDN @302@ is returned here, not chased with the bearer). The constructed URL is on the
private base host, so the 'Ecluse.Core.Security.TrustedOrigin' tarball-host gate is
satisfied __same-host__ (the host check is still applied, simply trivially met), and the
trusted origin is __exempt from the literal internal-range block__ (security.md
invariant 3): a private registry on an internal address (e.g. @https:\/\/registry.internal\/@,
served with a certificate the operator's image trusts) still serves its same-host tarball.

A @2xx@ is streamed through with bounded memory and yields 'Just' (the request is
answered); a non-@2xx@ status, an unformable URL, or a failure opening the connection
yields 'Nothing' so the caller falls through to the public origin, the upstream artifact
body never read. The client's conditional @validators@ are relayed onto the request
('forwardValidators' filtered them upstream), and the relay accepts an upstream @304 Not
Modified@ ('acceptArtifact') as well as a @2xx@: a private tarball is a pass-through body,
so a @304@ is relayed straight back to the client (bodiless) rather than treated as a
private miss falling through to the public origin.

A failure that strikes __after__ a @2xx@ has begun streaming is unrecoverable -- the
response is already on the wire -- so 'streamUpstreamWhen' lets it propagate rather than
reporting a miss: the request fails internally (the connection is torn down) instead of
responding a second time over a half-sent artifact.

This leg applies __no serve-time integrity floor__: an established version pinned in a
consumer's lockfile and served from an operator-trusted private registry is fast-tracked,
its bytes still verified client-side by @npm@ and by the mirror worker on ingestion. A
private upstream that serves its tarball off the conventional @\/-\/@ path (a separate
files host, a signed CDN URL) is not reached by this leg and is a clean miss that falls
through to the public origin. -}
streamPrivateArtifact ::
    ArtifactServe ->
    ServeRuntime ->
    PackumentDeps ->
    Maybe Secret ->
    RequestHeaders ->
    PackageName ->
    Text ->
    (Response -> IO ResponseReceived) ->
    Handler (Maybe ResponseReceived)
streamPrivateArtifact :: ArtifactServe
-> ServeRuntime
-> PackumentDeps
-> Maybe Secret
-> RequestHeaders
-> PackageName
-> Text
-> (Response -> IO ResponseReceived)
-> Handler (Maybe ResponseReceived)
streamPrivateArtifact ArtifactServe
mode ServeRuntime
rt PackumentDeps
deps Maybe Secret
token RequestHeaders
validators PackageName
name Text
file Response -> IO ResponseReceived
respond =
    case Maybe Request
privateRequest of
        Just Request
req -> IO (Maybe ResponseReceived) -> Handler (Maybe ResponseReceived)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ArtifactServe
-> Manager
-> Request
-> (Status -> Bool)
-> (Status -> RequestHeaders -> (Status, RequestHeaders))
-> (Response -> IO ResponseReceived)
-> IO (Maybe ResponseReceived)
relayUpstreamWhen ArtifactServe
mode (ServeRuntime -> Manager
srPrivateManager ServeRuntime
rt) Request
req Status -> Bool
acceptArtifact Status -> RequestHeaders -> (Status, RequestHeaders)
relayArtifact Response -> IO ResponseReceived
respond)
        Maybe Request
Nothing -> Maybe ResponseReceived -> Handler (Maybe ResponseReceived)
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ResponseReceived
forall a. Maybe a
Nothing
  where
    -- Build the conventional-URL private tarball request {base}/{pkg}/-/{file} by the
    -- requested filename, when its (same-)host passes the tarball-host policy and the URL
    -- forms. 'Nothing' on either refusal -- a private miss the caller falls through on. The
    -- constructed URL is on the private base host, so the host gate is trivially
    -- satisfied; it is kept applied rather than dropped. The request is marked with the
    -- serve mode's method (GET / HEAD) and carries the client's relayed conditional
    -- validators; 'artifactRequestByFile' attaches the forwarded credential with
    -- redirectCount = 0 (the credential-redirect invariant).
    privateRequest :: Maybe HTTP.Request
    privateRequest :: Maybe Request
privateRequest =
        if Origin -> PackumentDeps -> Text -> Text -> Bool
tarballHostHonoured Origin
TrustedOrigin PackumentDeps
deps Text
privateHost Text
privateHost
            then RequestHeaders -> Request -> Request
withValidators RequestHeaders
validators (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArtifactServe -> Request -> Request
withMethod ArtifactServe
mode (Request -> Request) -> Maybe Request -> Maybe Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either UrlFormationError Request -> Maybe Request
forall l r. Either l r -> Maybe r
rightToMaybe (PackumentDeps
-> Limits
-> Manager
-> Text
-> Maybe Secret
-> PackageName
-> Text
-> Either UrlFormationError Request
pdBuildArtifactRequestByFile PackumentDeps
deps (PackumentDeps -> Limits
pdLimits PackumentDeps
deps) (ServeRuntime -> Manager
srPrivateManager ServeRuntime
rt) (PackumentDeps -> Text
pdPrivateBaseUrl PackumentDeps
deps) Maybe Secret
token PackageName
name Text
file)
            else Maybe Request
forall a. Maybe a
Nothing
      where
        -- The precomputed private host: the constructed URL is on the private base
        -- host, so both the packument and the tarball host of the trusted gate are it
        -- (the check stays applied, trivially satisfied, without re-parsing the URL).
        privateHost :: Text
privateHost = TarballHostGate -> Text
thgPrivateHost (PackumentDeps -> TarballHostGate
pdTarballHostGate PackumentDeps
deps)

{- Serve the artifact from the public upstream after a private miss: gate the
single requested version against the rules, and on an admit stream the public bytes
(anonymously) and enqueue a mirror job; on a reject render the serve error model.
The public version metadata is fetched anonymously to decide. -}
servePublicArtifact ::
    ArtifactServe ->
    ServeRuntime ->
    MountRenderer ->
    PackumentDeps ->
    RequestHeaders ->
    PackageName ->
    Version ->
    Text ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
servePublicArtifact :: ArtifactServe
-> ServeRuntime
-> MountRenderer
-> PackumentDeps
-> RequestHeaders
-> PackageName
-> Version
-> Text
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
servePublicArtifact ArtifactServe
mode ServeRuntime
rt MountRenderer
renderer PackumentDeps
deps RequestHeaders
validators PackageName
name Version
version Text
file Response -> IO ResponseReceived
respond = do
    let metrics :: MetricsPort
metrics = ServeRuntime -> MetricsPort
srMetrics ServeRuntime
rt
    MetricsPort
-> ServeAdmission
-> Handler PublicArtifactGate
-> Handler (Maybe PublicArtifactGate)
forall (m :: * -> *) a.
MonadUnliftIO m =>
MetricsPort -> ServeAdmission -> m a -> m (Maybe a)
withServeAdmission MetricsPort
metrics (ServeRuntime -> ServeAdmission
srAdmission ServeRuntime
rt) (ServeRuntime
-> PackumentDeps
-> PackageName
-> Version
-> Text
-> Handler PublicArtifactGate
gatePublicVersion ServeRuntime
rt PackumentDeps
deps PackageName
name Version
version Text
file) Handler (Maybe PublicArtifactGate)
-> (Maybe PublicArtifactGate -> Handler ResponseReceived)
-> Handler ResponseReceived
forall a b. Handler a -> (a -> Handler b) -> Handler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (Admitted Artifact
artifact) -> do
            IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> Decision -> IO ()
mpServeDecision MetricsPort
metrics Decision
Metric.Admit)
            IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ArtifactServe
-> ServeRuntime
-> MountRenderer
-> PackumentDeps
-> RequestHeaders
-> PackageName
-> Version
-> Artifact
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
streamPublicArtifact ArtifactServe
mode ServeRuntime
rt MountRenderer
renderer PackumentDeps
deps RequestHeaders
validators PackageName
name Version
version Artifact
artifact Response -> IO ResponseReceived
respond)
        Just (Refused ServeDecision
decision) -> IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> Handler ResponseReceived)
-> IO ResponseReceived -> Handler ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
            MetricsPort -> Decision -> IO ()
mpServeDecision MetricsPort
metrics (ServeDecision -> Decision
serveDecisionClass ServeDecision
decision)
            MetricsPort -> [ServeDecision] -> IO ()
recordDenials MetricsPort
metrics [ServeDecision
decision]
            Response -> IO ResponseReceived
respond (MountRenderer
-> PackumentDeps -> ArtifactStatus -> ServeDecision -> Response
artifactError MountRenderer
renderer PackumentDeps
deps (ServeDecision -> ArtifactStatus
artifactStatus ServeDecision
decision) ServeDecision
decision)
        Maybe PublicArtifactGate
Nothing -> IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> Handler ResponseReceived)
-> IO ResponseReceived -> Handler ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
            MetricsPort -> Decision -> IO ()
mpServeDecision MetricsPort
metrics Decision
Metric.Unavailable
            Response -> IO ResponseReceived
respond (MountRenderer -> Response
serveOverloaded MountRenderer
renderer)

{- The outcome of gating a single requested artifact on the public path: either the
chosen 'Artifact' to fetch, or the serve decision the error model renders. The
admit carries the artifact so the stream step honours its 'artUrl' rather than
re-deciding or reconstructing the location. -}
data PublicArtifactGate
    = -- | The version was admitted; carries the artifact selected by filename.
      Admitted Artifact
    | -- | The version was refused (policy denial, upstream outage, or absence).
      Refused ServeDecision

{- Gate the single requested version against the rules engine and select its
artifact, returning the gate outcome. The single-version metadata is fetched through the
public origin's read handle ('fetchVersionMetadata'), which resolves the full packument
__through the shared metadata cache__ -- so a packument @GET@ and the tarball gate that
follows still collapse to one upstream call -- and selects the requested version's
'PackageDetails'. That version is evaluated through 'Ecluse.Core.Rules.evalRules' (the same
engine the packument path gates with). On an admit the artifact matching the requested
filename is selected ('artifactFor'); a filename absent from an otherwise-admitted version
is a forwarded miss, the same @404@ as an absent version.

The refusal causes the error model maps: a version (or file) absent from the public
metadata is a genuine miss (a @404@ forwarded absence, projected as 'Unavailable'
'WontResolve' only to carry a non-admit -- the status is overridden to @404@ in
'artifactError'); a metadata fetch that fails -- a transport outage or any 'MetadataError',
a misreporting origin included -- is a transient upstream outage (@503@), the single-version
path collapsing every unobtainable-metadata cause to the same retryable outage; a present
version is decided by the rules, where a needed effectful rule that cannot be consulted
fail-closes to an 'Unavailable' @503@\/@500@. -}
gatePublicVersion :: ServeRuntime -> PackumentDeps -> PackageName -> Version -> Text -> Handler PublicArtifactGate
gatePublicVersion :: ServeRuntime
-> PackumentDeps
-> PackageName
-> Version
-> Text
-> Handler PublicArtifactGate
gatePublicVersion ServeRuntime
rt PackumentDeps
deps PackageName
name Version
version Text
file = do
    evalCtx <- IO EvalContext -> Handler EvalContext
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (UTCTime -> EvalContext
EvalContext (UTCTime -> EvalContext) -> IO UTCTime -> IO EvalContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackumentDeps -> IO UTCTime
pdNow PackumentDeps
deps)
    eval <-
        withPublicMetadataClient rt deps (pdPublicBaseUrl deps) $ \MetadataClient
client ->
            IO VersionEvaluation -> IO VersionEvaluation
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetadataClient -> PackageName -> Version -> IO VersionEvaluation
fetchVersionDetails MetadataClient
client PackageName
name Version
version)
    case eval of
        VersionEvaluation
VersionMetadataUnavailable -> PublicArtifactGate -> Handler PublicArtifactGate
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServeDecision -> PublicArtifactGate
Refused ServeDecision
upstreamUnavailable)
        VersionEvaluation
VersionMissing -> PublicArtifactGate -> Handler PublicArtifactGate
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServeDecision -> PublicArtifactGate
Refused ServeDecision
versionAbsent)
        VersionPresent PackageDetails
details ->
            -- The rule-eval domain span wraps the actual decision (only reached once
            -- the version exists), recording the verdict so a denial → 403 is
            -- explainable from the trace; the upstream-outage and version-absent
            -- branches above are not rule evaluations and carry no span.
            IO PublicArtifactGate -> Handler PublicArtifactGate
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PublicArtifactGate -> Handler PublicArtifactGate)
-> IO PublicArtifactGate -> Handler PublicArtifactGate
forall a b. (a -> b) -> a -> b
$
                TracingPort
-> forall a.
   PackageName -> Version -> IO (a, ServeDecision) -> IO a
spanRuleEval (ServeRuntime -> TracingPort
srTracing ServeRuntime
rt) PackageName
name Version
version (IO (PublicArtifactGate, ServeDecision) -> IO PublicArtifactGate)
-> IO (PublicArtifactGate, ServeDecision) -> IO PublicArtifactGate
forall a b. (a -> b) -> a -> b
$ do
                    (gate, seconds) <- IO PublicArtifactGate -> IO (PublicArtifactGate, Double)
forall (m :: * -> *) a. MonadIO m => m a -> m (a, Double)
timedSeconds (EvalContext
-> PackumentDeps -> Text -> PackageDetails -> IO PublicArtifactGate
gateVersion EvalContext
evalCtx PackumentDeps
deps Text
file PackageDetails
details)
                    mpRuleEvalDuration (srMetrics rt) (evalTier (pdRules deps)) seconds
                    pure (gate, gateVerdict gate)

-- The serve verdict a public-artifact gate outcome carries, for the rule-eval span:
-- an admitted version admits; a refused one carries the decision the serve error
-- model renders.
gateVerdict :: PublicArtifactGate -> ServeDecision
gateVerdict :: PublicArtifactGate -> ServeDecision
gateVerdict = \case
    Admitted Artifact
_ -> ServeDecision
Admit
    Refused ServeDecision
decision -> ServeDecision
decision

{- Project a single version's rule decision to a gate outcome, selecting the
artifact by filename on an admit. A denied version is 'Refused' with its decision; an
admitted version whose requested filename matches no artifact is a forwarded miss
('versionAbsent', rendered @404@).

The __integrity-floor admission policy__ is enforced here, after the rules admit and
the artifact is selected: a public version whose selected artifact carries no digest
meeting the floor ('pdMinIntegrity') is inadmissible -- 'integrityMissing' (no digest at
all) or 'integrityBelowFloor' (a digest, but too weak), both rendered @403@ -- and
refused outright, never fetched. This is the public path; the trusted (private) artifact
serve is a conventional stable read in 'streamPrivateArtifact' that applies no serve-time
integrity floor, so it never reaches this gate. -}
gateVersion :: EvalContext -> PackumentDeps -> Text -> PackageDetails -> IO PublicArtifactGate
gateVersion :: EvalContext
-> PackumentDeps -> Text -> PackageDetails -> IO PublicArtifactGate
gateVersion EvalContext
ctx PackumentDeps
deps Text
file PackageDetails
details = do
    decision <- PackageDetails -> Decision -> ServeDecision
serveDecisionOf PackageDetails
details (Decision -> ServeDecision) -> IO Decision -> IO ServeDecision
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalContext -> [PreparedRule] -> PackageDetails -> IO Decision
evalRules EvalContext
ctx (PackumentDeps -> [PreparedRule]
pdRules PackumentDeps
deps) PackageDetails
details
    pure $ case decision of
        ServeDecision
Admit -> PublicArtifactGate
-> (Artifact -> PublicArtifactGate)
-> Maybe Artifact
-> PublicArtifactGate
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ServeDecision -> PublicArtifactGate
Refused ServeDecision
versionAbsent) Artifact -> PublicArtifactGate
admitWithIntegrity (Text -> PackageDetails -> Maybe Artifact
artifactFor Text
file PackageDetails
details)
        Reject Rejection
_ -> ServeDecision -> PublicArtifactGate
Refused ServeDecision
decision
  where
    -- A rule-admitted artifact is served only if it carries a digest meeting the floor;
    -- a weaker-than-floor or hashless one is refused by the integrity-floor policy.
    admitWithIntegrity :: Artifact -> PublicArtifactGate
    admitWithIntegrity :: Artifact -> PublicArtifactGate
admitWithIntegrity Artifact
artifact = case MinIntegrity -> NonEmpty Artifact -> VersionIntegrity
forall floor.
IntegrityFloor floor =>
floor -> NonEmpty Artifact -> VersionIntegrity
classifyArtifacts (PackumentDeps -> MinIntegrity
pdMinIntegrity PackumentDeps
deps) (Artifact
artifact Artifact -> [Artifact] -> NonEmpty Artifact
forall a. a -> [a] -> NonEmpty a
:| []) of
        VersionIntegrity
MeetsFloor -> Artifact -> PublicArtifactGate
Admitted Artifact
artifact
        VersionIntegrity
BelowFloor -> ServeDecision -> PublicArtifactGate
Refused ServeDecision
integrityBelowFloor
        VersionIntegrity
NoIntegrity -> ServeDecision -> PublicArtifactGate
Refused ServeDecision
integrityMissing

-- A transient public-upstream outage: a 'WillResolve' rejection (→ @503@).
upstreamUnavailable :: ServeDecision
upstreamUnavailable :: ServeDecision
upstreamUnavailable =
    Rejection -> ServeDecision
Reject (RejectReason -> Text -> Rejection
Rejection (Transience -> RejectReason
Unavailable (Maybe RetryAfter -> Transience
WillResolve Maybe RetryAfter
forall a. Maybe a
Nothing)) Text
"the upstream registry was unavailable")

{- A version not present in the public metadata: a non-admit carrying a
'WontResolve' cause, whose status 'artifactError' overrides to a @404@ forwarded
miss (the package may exist, this version does not). -}
versionAbsent :: ServeDecision
versionAbsent :: ServeDecision
versionAbsent =
    Rejection -> ServeDecision
Reject (RejectReason -> Text -> Rejection
Rejection (Transience -> RejectReason
Unavailable Transience
WontResolve) Text
"the requested version was not found upstream")

{- Stream the artifact from the public upstream at its __authoritative location__,
__anonymously__ (the client credential is never sent to the public upstream), and --
__after__ the response is begun -- enqueue a best-effort mirror job. The chosen
'Artifact''s 'artUrl' is honoured directly rather than reconstructed (it is an
https-only URL, normalised at projection); the tarball-host policy gates whether that
location may be fetched (the public packument host is the reference), and certificate
validation on 'srPublicManager' authenticates the host. A host the policy refuses is the
@403@ policy-denial path; an unformable URL is the internal-error path.

The fetch keeps the open phase distinct from the committed stream, the same split the
private origin uses: opening the connection is the recoverable phase, so a transient
network failure or a TLS handshake failure (a host that cannot present a CA-trusted
certificate for the requested name) yields no committed response and is rendered as the
transient upstream-unavailable @503@ through the mount's renderer, not left to escape as
a bare @500@. Any upstream status is relayed
verbatim (the @accept@ predicate is total); only a failure __after__ the stream is
committed propagates, the connection torn down as it unwinds, so a half-sent artifact
is never followed by a second response. The mirror enqueue runs only on the committed
path, after the response is begun.

The client's conditional @validators@ are relayed onto the upstream artifact request
('forwardValidators' filtered them); the public artifact is a pass-through body, so an
upstream @304 Not Modified@ is relayed straight back to the client (bodiless, via
'streamUpstreamWhen'), the bytes never re-downloaded. The validators carry no
credential and the public fetch stays anonymous. -}
streamPublicArtifact ::
    ArtifactServe ->
    ServeRuntime ->
    MountRenderer ->
    PackumentDeps ->
    RequestHeaders ->
    PackageName ->
    Version ->
    Artifact ->
    (Response -> IO ResponseReceived) ->
    IO ResponseReceived
streamPublicArtifact :: ArtifactServe
-> ServeRuntime
-> MountRenderer
-> PackumentDeps
-> RequestHeaders
-> PackageName
-> Version
-> Artifact
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
streamPublicArtifact ArtifactServe
mode ServeRuntime
rt MountRenderer
renderer PackumentDeps
deps RequestHeaders
validators PackageName
name Version
version Artifact
artifact Response -> IO ResponseReceived
respond
    | Bool -> Bool
not Bool
hostHonoured = Response -> IO ResponseReceived
respond Response
crossHostRefused
    | Bool
otherwise = case Either UrlFormationError Request
publicRequest of
        Left UrlFormationError
_ -> Response -> IO ResponseReceived
respond Response
internalArtifactError
        Right Request
req ->
            ArtifactServe
-> Manager
-> Request
-> (Status -> Bool)
-> (Status -> RequestHeaders -> (Status, RequestHeaders))
-> (Response -> IO ResponseReceived)
-> IO (Maybe ResponseReceived)
relayUpstreamWhen ArtifactServe
mode (ServeRuntime -> Manager
srPublicManager ServeRuntime
rt) Request
req (Bool -> Status -> Bool
forall a b. a -> b -> a
const Bool
True) Status -> RequestHeaders -> (Status, RequestHeaders)
relayArtifact Response -> IO ResponseReceived
respond IO (Maybe ResponseReceived)
-> (Maybe ResponseReceived -> 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
>>= \case
                Just ResponseReceived
received -> do
                    -- Mirroring is demand-driven on the GET path only: a HEAD serves
                    -- no bytes, so there is nothing to back-fill.
                    ArtifactServe -> IO () -> IO ()
enqueueOnFull ArtifactServe
mode (ServeRuntime
-> PackumentDeps -> PackageName -> Version -> Artifact -> IO ()
enqueueMirror ServeRuntime
rt PackumentDeps
deps PackageName
name Version
version Artifact
artifact)
                    ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
received
                Maybe ResponseReceived
Nothing -> Response -> IO ResponseReceived
respond (MountRenderer
-> PackumentDeps -> ArtifactStatus -> ServeDecision -> Response
artifactError MountRenderer
renderer PackumentDeps
deps (ServeDecision -> ArtifactStatus
artifactStatus ServeDecision
upstreamUnavailable) ServeDecision
upstreamUnavailable)
  where
    hostHonoured :: Bool
hostHonoured = Origin -> PackumentDeps -> Text -> Text -> Bool
tarballHostHonoured Origin
UntrustedOrigin PackumentDeps
deps (TarballHostGate -> Text
thgPublicHost (PackumentDeps -> TarballHostGate
pdTarballHostGate PackumentDeps
deps)) (Text -> Text
hostAddress (Artifact -> Text
artUrl Artifact
artifact))

    publicRequest :: Either UrlFormationError Request
publicRequest = RequestHeaders -> Request -> Request
withValidators RequestHeaders
validators (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArtifactServe -> Request -> Request
withMethod ArtifactServe
mode (Request -> Request)
-> Either UrlFormationError Request
-> Either UrlFormationError Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackumentDeps
-> Limits
-> Manager
-> Text
-> Maybe Secret
-> Text
-> Either UrlFormationError Request
pdBuildArtifactRequestByUrl PackumentDeps
deps (PackumentDeps -> Limits
pdLimits PackumentDeps
deps) (ServeRuntime -> Manager
srPublicManager ServeRuntime
rt) (PackumentDeps -> Text
pdPublicBaseUrl PackumentDeps
deps) Maybe Secret
forall a. Maybe a
Nothing (Artifact -> Text
artUrl Artifact
artifact)

{- Tag an upstream artifact request with the serve mode's method: a 'ServeFull' fetch
keeps the request's default @GET@, a 'ServeHead' probe is marked @HEAD@ so the upstream
sees a bodiless request and the proxy never pumps the body. -}
withMethod :: ArtifactServe -> HTTP.Request -> HTTP.Request
withMethod :: ArtifactServe -> Request -> Request
withMethod = \case
    ArtifactServe
ServeFull -> Request -> Request
forall a. a -> a
id
    ArtifactServe
ServeHead -> \Request
req -> Request
req{HTTP.method = methodHead}

{- Relay the client's conditional validators (the @If-None-Match@ \/ @If-Modified-Since@
'forwardValidators' filtered) onto an upstream artifact request, so upstream can answer
a @304 Not Modified@ for a pass-through body we serve unchanged. An empty validator set
(the client sent none) leaves the request unconditional. -}
withValidators :: RequestHeaders -> HTTP.Request -> HTTP.Request
withValidators :: RequestHeaders -> Request -> Request
withValidators RequestHeaders
validators Request
req =
    Request
req{HTTP.requestHeaders = validators <> HTTP.requestHeaders req}

{- The upstream artifact statuses the private relay accepts back to the client: a
@2xx@ success (the streamed artifact) or a @304 Not Modified@ (the pass-through
conditional-GET relay -- the client's relayed validators matched upstream's, so the
unchanged artifact is answered as a bodiless @304@ by 'streamUpstreamWhen' rather than
re-downloaded). Any other status is a clean private miss the caller falls through on.
(The public relay accepts every status -- it relays whatever the public origin returns
verbatim -- so it needs no predicate of its own.) -}
acceptArtifact :: Status -> Bool
acceptArtifact :: Status -> Bool
acceptArtifact Status
s = Status -> Bool
statusIsSuccessful Status
s Bool -> Bool -> Bool
|| Status -> Bool
isNotModified Status
s

{- Relay an upstream artifact response in the serve mode: 'ServeFull' streams the body
through with bounded memory ('streamUpstreamWhen'); 'ServeHead' probes bodiless,
relaying the status and headers with no body ('probeUpstreamWhen'). Both keep the same
recoverable-miss / committed split, so a HEAD falls through a private miss to the public
origin exactly as a GET does. -}
relayUpstreamWhen ::
    ArtifactServe ->
    Manager ->
    HTTP.Request ->
    (Status -> Bool) ->
    (Status -> ResponseHeaders -> (Status, ResponseHeaders)) ->
    (Response -> IO ResponseReceived) ->
    IO (Maybe ResponseReceived)
relayUpstreamWhen :: ArtifactServe
-> Manager
-> Request
-> (Status -> Bool)
-> (Status -> RequestHeaders -> (Status, RequestHeaders))
-> (Response -> IO ResponseReceived)
-> IO (Maybe ResponseReceived)
relayUpstreamWhen = \case
    ArtifactServe
ServeFull -> Manager
-> Request
-> (Status -> Bool)
-> (Status -> RequestHeaders -> (Status, RequestHeaders))
-> (Response -> IO ResponseReceived)
-> IO (Maybe ResponseReceived)
streamUpstreamWhen
    ArtifactServe
ServeHead -> Manager
-> Request
-> (Status -> Bool)
-> (Status -> RequestHeaders -> (Status, RequestHeaders))
-> (Response -> IO ResponseReceived)
-> IO (Maybe ResponseReceived)
probeUpstreamWhen

-- Run the demand-driven mirror enqueue only on the 'ServeFull' (GET) path; a
-- 'ServeHead' served no bytes, so it back-fills nothing.
enqueueOnFull :: ArtifactServe -> IO () -> IO ()
enqueueOnFull :: ArtifactServe -> IO () -> IO ()
enqueueOnFull ArtifactServe
mode IO ()
act = case ArtifactServe
mode of
    ArtifactServe
ServeFull -> IO ()
act
    ArtifactServe
ServeHead -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass

{- Enqueue a demand-driven mirror job for an admitted artifact, __best-effort__: it
runs after the client response is begun and any failure is swallowed, so a queue
outage never fails or delays the serve. The 'enqueue' it calls is the composition
root's buffered hand-off ('Ecluse.Core.Queue.newEnqueueBuffer'), so even a slow
backend's own producer latency (the SQS round trip) stays off the request path
rather than holding the served connection's turn. The job names the artifact's
authoritative URL (the same location the public fetch targeted) and the mount's
mirror target; it carries no credential (the worker mints its own).

It also captures the __serve-time-admitted__ integrity digests, filename, and
declared size on the job, so the worker verifies the fetched bytes against exactly
what the rules cleared (immune to an upstream packument mutated in the
enqueue → process window) and can assemble the publish document without re-fetching.
The artifact reached this point through the integrity-presence admission policy, so
'artHashes' is non-empty; a hashless artifact (which that policy already refuses to
serve) is not enqueued, since there would be no digest to verify against. -}
enqueueMirror :: ServeRuntime -> PackumentDeps -> PackageName -> Version -> Artifact -> IO ()
enqueueMirror :: ServeRuntime
-> PackumentDeps -> PackageName -> Version -> Artifact -> IO ()
enqueueMirror ServeRuntime
rt PackumentDeps
deps PackageName
name Version
version Artifact
artifact =
    Maybe (NonEmpty Hash) -> (NonEmpty Hash -> IO ()) -> IO ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust ([Hash] -> Maybe (NonEmpty Hash)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Artifact -> [Hash]
artHashes Artifact
artifact)) ((NonEmpty Hash -> IO ()) -> IO ())
-> (NonEmpty Hash -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Hash
hashes ->
        IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> ((Maybe RemoteSpanContext -> IO (Either SomeException ()))
    -> IO (Either SomeException ()))
-> (Maybe RemoteSpanContext -> IO (Either SomeException ()))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracingPort
-> forall a.
   PackageName
   -> Version
   -> Text
   -> (a -> Maybe Text)
   -> (Maybe RemoteSpanContext -> IO a)
   -> IO a
spanMirrorEnqueue (ServeRuntime -> TracingPort
srTracing ServeRuntime
rt) PackageName
name Version
version (Artifact -> Text
artUrl Artifact
artifact) Either SomeException () -> Maybe Text
enqueueErrorDetail ((Maybe RemoteSpanContext -> IO (Either SomeException ()))
 -> IO ())
-> (Maybe RemoteSpanContext -> IO (Either SomeException ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$
            NonEmpty Hash
-> Maybe RemoteSpanContext -> IO (Either SomeException ())
enqueueJob NonEmpty Hash
hashes
  where
    enqueueJob :: NonEmpty Hash
-> Maybe RemoteSpanContext -> IO (Either SomeException ())
enqueueJob NonEmpty Hash
hashes Maybe RemoteSpanContext
traceContext = do
        enqueued <- IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (MirrorQueue -> MirrorJob -> IO ()
enqueue (ServeRuntime -> MirrorQueue
srQueue ServeRuntime
rt) (NonEmpty Hash -> Maybe RemoteSpanContext -> MirrorJob
mirrorJob NonEmpty Hash
hashes Maybe RemoteSpanContext
traceContext))
        -- Best-effort: the hand-off outcome is counted but never propagated, so
        -- a refused hand-off records a failure rather than failing or delaying
        -- the serve. (Drops and backend delivery failures behind the buffered
        -- hand-off are counted by the composition root's buffer callbacks.)
        either (const (mpMirrorEnqueueFailure (srMetrics rt))) (const (mpMirrorEnqueued (srMetrics rt))) enqueued
        -- Hand the outcome back so the span bracket can mark a swallowed failure
        -- errored on the producer span (the metric counts it; the span explains it).
        pure enqueued

    mirrorJob :: NonEmpty Hash -> Maybe RemoteSpanContext -> MirrorJob
mirrorJob NonEmpty Hash
hashes Maybe RemoteSpanContext
traceContext =
        MirrorJob
            { jobPackage :: PackageName
jobPackage = PackageName
name
            , jobVersion :: Version
jobVersion = Version
version
            , jobArtifactUrl :: Text
jobArtifactUrl = Artifact -> Text
artUrl Artifact
artifact
            , jobMirrorTarget :: Text
jobMirrorTarget = PackumentDeps -> Text
pdMirrorTarget PackumentDeps
deps
            , jobArtifact :: MirrorArtifact
jobArtifact =
                MirrorArtifact
                    { maFilename :: Text
maFilename = Artifact -> Text
artFilename Artifact
artifact
                    , maHashes :: NonEmpty Hash
maHashes = NonEmpty Hash
hashes
                    , maSize :: Maybe Int
maSize = Artifact -> Maybe Int
artSize Artifact
artifact
                    }
            , -- The enqueueing span's trace context, captured by the span
              -- bracket, so the worker's per-job span links back across the hop.
              jobTraceContext :: Maybe RemoteSpanContext
jobTraceContext = Maybe RemoteSpanContext
traceContext
            }

    -- Project the swallowed enqueue outcome onto the producer span's status: a failure
    -- records the cause (so a trace explains why the mirror was not enqueued), a success
    -- leaves the status unset.
    enqueueErrorDetail :: Either SomeException () -> Maybe Text
    enqueueErrorDetail :: Either SomeException () -> Maybe Text
enqueueErrorDetail = (SomeException -> Maybe Text)
-> (() -> Maybe Text) -> Either SomeException () -> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> (SomeException -> Text) -> SomeException -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
enqueueFailureDetail) (Maybe Text -> () -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)

    enqueueFailureDetail :: SomeException -> Text
    enqueueFailureDetail :: SomeException -> Text
enqueueFailureDetail SomeException
e = Text
"mirror enqueue failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)

{- Whether an artifact's @dist.tarball@ host may be fetched, given the origin's trust,
the mount's tarball-host policy, and the host that served the packument it came from.
Connects the pure 'tarballHostAllowed' at the serve boundary: the tarball host must be on
the upstream allowlist and -- under the secure-default
'Ecluse.Core.Security.SameHostAsPackument' -- equal to the packument host; the opt-in
'Ecluse.Core.Security.AnyAllowlistedHost' relaxes that last clause to any allowlisted host.
This is the policy half of the @dist.tarball@ defence; the egress itself is https-only
with certificate validation authenticating the host (see "Ecluse.Core.Security.Egress").

The @packumentHost@ and @artifactHost@ are bare hosts, __already extracted__: the
mount-constant ones (the upstream allowlist and the private\/public hosts) are precomputed
once at the composition root into the 'Ecluse.Core.Security.TarballHostGate' carried on
'pdTarballHostGate', so the hot path parses no base URL and rebuilds no allowlist per
request; only the dynamic public @dist.tarball@ host is parsed at the call site.

The literal internal-range block is __origin-aware__: an
'Ecluse.Core.Security.UntrustedOrigin' (the public path) is gated against the fixed
range set plus the operator-configured @additionalBlockedRanges@, while an
'Ecluse.Core.Security.TrustedOrigin' (the operator-configured private upstream) is exempt,
since a private registry may legitimately live on an internal address (security.md
invariant 3). The allowlist and same-host clauses still gate the trusted origin
identically. -}
tarballHostHonoured :: Origin -> PackumentDeps -> Text -> Text -> Bool
tarballHostHonoured :: Origin -> PackumentDeps -> Text -> Text -> Bool
tarballHostHonoured Origin
origin PackumentDeps
deps =
    Origin
-> TarballHostPolicy
-> LoweredHostSet
-> [IPRange]
-> Text
-> Text
-> Bool
tarballHostAllowed
        Origin
origin
        (PackumentDeps -> TarballHostPolicy
pdTarballHostPolicy PackumentDeps
deps)
        (TarballHostGate -> LoweredHostSet
thgAllowlist (PackumentDeps -> TarballHostGate
pdTarballHostGate PackumentDeps
deps))
        (PackumentDeps -> [IPRange]
pdAdditionalBlockedRanges PackumentDeps
deps)

{- Select the artifact a request's filename names from a version's distribution
files. npm has exactly one artifact per version, so the match is the single file; a
many-per-version ecosystem (PyPI) would select the wheel\/sdist whose filename the
client requested. 'Nothing' when no artifact carries the requested filename -- a
forwarded miss, never a fabricated location. -}
artifactFor :: Text -> PackageDetails -> Maybe Artifact
artifactFor :: Text -> PackageDetails -> Maybe Artifact
artifactFor Text
file PackageDetails
details =
    (Artifact -> Bool) -> NonEmpty Artifact -> Maybe Artifact
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
file) (Text -> Bool) -> (Artifact -> Text) -> Artifact -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Artifact -> Text
artFilename) (PackageDetails -> NonEmpty Artifact
pkgArtifacts PackageDetails
details)

{- A @403@ for an artifact whose authoritative @url@ the tarball-host policy refuses:
a cross-host @dist.tarball@ under the secure-default 'Ecluse.Core.Security.SameHostAsPackument',
or a host off the upstream allowlist. A policy denial, not a serve outcome the rules
produced -- the same @403@ surface a rule denial renders, with a fixed reason. -}
crossHostRefused :: Response
crossHostRefused :: Response
crossHostRefused =
    Status -> RequestHeaders -> ByteString -> Response
responseLBS (Int -> ByteString -> Status
mkStatus Int
403 ByteString
"Forbidden") [(HeaderName
hContentType, ByteString
"application/json")] ByteString
"{\"error\":\"the upstream artifact host is not permitted by the tarball-host policy\"}"

{- The relay for an artifact stream: forward the upstream status and headers,
dropping only the hop-by-hop framing headers (@Transfer-Encoding@, @Connection@)
whose values describe the upstream hop, not the artifact. The body is opaque binary
streamed verbatim, so the content headers (type, length, encoding) and the
upstream's @ETag@ pass through unchanged -- the client verifies the artifact's own
@dist.integrity@ over exactly these bytes. -}
relayArtifact :: Status -> ResponseHeaders -> (Status, ResponseHeaders)
relayArtifact :: Status -> RequestHeaders -> (Status, RequestHeaders)
relayArtifact Status
status RequestHeaders
headers =
    (Status
status, (Header -> Bool) -> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Header -> Bool) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> Bool
forall {a}. (Eq a, IsString a) => a -> Bool
isHopByHop (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst) RequestHeaders
headers)
  where
    isHopByHop :: a -> Bool
isHopByHop a
name = a
name a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"Transfer-Encoding" Bool -> Bool -> Bool
|| a
name a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"Connection"

{- Render a non-admit artifact outcome as the serve error model: @403@ for a policy
denial, @503@ for a transient upstream unavailability, @404@ for a forwarded
upstream miss (the requested version is absent), @500@ otherwise. The body is shaped
by the mount's renderer; a transient status carries no suggested delay here (the
single-artifact path has none to offer). A @404@ is the version-absent miss, which
'gatePublicVersion' flags as a 'WontResolve' rejection -- the only such cause on this
path -- so it is mapped to @404@ rather than the @500@ a 'WontResolve' would
otherwise render. -}
artifactError :: MountRenderer -> PackumentDeps -> ArtifactStatus -> ServeDecision -> Response
artifactError :: MountRenderer
-> PackumentDeps -> ArtifactStatus -> ServeDecision -> Response
artifactError MountRenderer
renderer PackumentDeps
deps ArtifactStatus
status ServeDecision
decision =
    Status -> RequestHeaders -> RenderedBody -> Response
renderedResponse (ArtifactStatus -> Status
toStatus ArtifactStatus
actualStatus) RequestHeaders
retryHeaders (MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer (PackumentDeps -> Maybe HelpMessage
pdHelp PackumentDeps
deps) Text
message)
  where
    retryHeaders :: ResponseHeaders
    retryHeaders :: RequestHeaders
retryHeaders = case ArtifactStatus
actualStatus of
        Unavailable' (Just (RetryAfter Int
secs)) -> [(HeaderName
hRetryAfter, Int -> ByteString
forall b a. (Show a, IsString b) => a -> b
show Int
secs)]
        ArtifactStatus
_ -> []
    -- The version-absent miss is carried as a 'WontResolve' rejection but rendered
    -- as a forwarded @404@, not the @500@ a generic 'WontResolve' maps to.
    actualStatus :: ArtifactStatus
    actualStatus :: ArtifactStatus
actualStatus = if Bool
isVersionAbsent then ArtifactStatus
NotFound else ArtifactStatus
status

    isVersionAbsent :: Bool
    isVersionAbsent :: Bool
isVersionAbsent = case ServeDecision
decision of
        Reject (Rejection (Unavailable Transience
WontResolve) Text
_) -> Bool
True
        ServeDecision
_ -> Bool
False

    toStatus :: ArtifactStatus -> Status
    toStatus :: ArtifactStatus -> Status
toStatus ArtifactStatus
s = Int -> ByteString -> Status
mkStatus (ArtifactStatus -> Int
artifactStatusCode ArtifactStatus
s) (ArtifactStatus -> ByteString
statusReason ArtifactStatus
s)

    statusReason :: ArtifactStatus -> ByteString
    statusReason :: ArtifactStatus -> ByteString
statusReason = \case
        ArtifactStatus
Ok -> ByteString
"OK"
        ArtifactStatus
Forbidden -> ByteString
"Forbidden"
        Unavailable'{} -> ByteString
"Service Unavailable"
        ArtifactStatus
ServerError -> ByteString
"Internal Server Error"
        ArtifactStatus
NotFound -> ByteString
"Not Found"

    message :: Text
    message :: Text
message = case ServeDecision
decision of
        ServeDecision
Admit -> Text
"the artifact is available"
        Reject Rejection
rej -> Rejection -> Text
rejectionMessage Rejection
rej

{- A @500@ for an unformable upstream artifact URL -- a configuration fault, not a
serve decision. The package segment and filename are already known-safe, so this is
reachable only on a misconfigured base URL; it is the internal-error tier, distinct
from the rule\/upstream outcomes 'artifactError' renders. -}
internalArtifactError :: Response
internalArtifactError :: Response
internalArtifactError =
    Status -> RequestHeaders -> ByteString -> Response
responseLBS (Int -> ByteString -> Status
mkStatus Int
500 ByteString
"Internal Server Error") [(HeaderName
hContentType, ByteString
"application/json")] ByteString
"{\"error\":\"could not form the upstream artifact URL\"}"