{- | The serve paths behind the package routes: the packument merge behind
@GET \/{pkg}@.

This is the data-plane handler module for packuments. It composes the
slices that decide /what/ to serve -- the registry client
("Ecluse.Core.Registry.Npm"), the per-version rules ("Ecluse.Core.Rules"), the structural
filter ("Ecluse.Core.Registry.Npm.Filter"), the cross-upstream merge
("Ecluse.Core.Package.Merge"), the metadata cache ("Ecluse.Core.Server.Cache"), the
own-ETag conditional ("Ecluse.Core.Server.Conditional"), and the serve-outcome status
("Ecluse.Core.Server.Response") -- 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'.

== Credential authority

This handler implements the default @passthrough@ credential posture (see
@docs\/architecture\/access-model.md@). The invariant that holds under __every__
strategy is the __public strip__: the client's credential is __stripped before any
public-upstream fetch__, which is always anonymous -- sending an internal token to the
public registry would be a credential disclosure, so the public-upstream fetch is built
with no token at all. Under @passthrough@ the client's own credential is additionally
__forwarded verbatim to the private upstream__, which is the authority for who may
read what. The two origins are fetched concurrently, each with its own credential
posture; nothing shares a token across the trust split.

Because @passthrough@ makes the private upstream the __per-client authority__, its
metadata is __not cached across clients__ here: the private origin is fetched and parsed on
every request with that client's own credential, so the upstream re-authorises each
client itself, and only the anonymous public origin is cached (one shared document, no
per-client authority to preserve). Caching the private origin keyed by base URL alone
would let one client's cached entry serve another client's private document within the
TTL, bypassing the upstream's authorisation -- a cross-client disclosure. (Other
strategies make the private origin shareable by authorising each serve differently; the
metadata cache itself stays credential-free regardless -- see
@docs\/architecture\/access-model.md@ → "Caching".)

== Merge, not fallback

A packument is the /set of available versions/, spread across upstreams, so it is
__merged__ rather than short-circuited on a private hit (see
@docs\/architecture\/registry-model.md@ → "Packument merge across upstreams").
Private versions are trusted and enter unfiltered; public versions are gated
through the rules and the structural filter (the 'FilterPlan''s survivors restrict
the typed view) before they enter; the two are combined, private winning a collision and
an integrity divergence flagged. If one upstream
is unavailable while the other succeeds, the best-effort union of what resolved is
served -- only when /nothing/ resolves does the request error.

== Decision surface vs served surface

The merge and filter reason over the /typed/ 'PackageInfo' but the document served
is the __raw upstream JSON__, so every unmodeled wire key survives (see
@docs\/architecture\/registry-model.md@ → "Decision surface vs served surface").
The 'MergePlan' names, for each surviving version, the source that won it; the
served body is assembled in one pass by the mount's assembly hook
('Ecluse.Core.Registry.Npm.Filter.assembleMergedPackument' for npm): each
survivor's object is taken from the /raw @Value@/ of its winning source with its
tarball URL rewritten under the mount base as it is placed, the reconciled
@dist-tags@ and @time@ are carried from the plan, and every other top-level key is
relayed from the precedence-winning document. The typed model is never
re-serialised. The two fields the merge /owns/ as a decision -- @dist-tags.latest@
and the @time@ instants -- are re-rendered from that decision (the times as
normalised ISO-8601), so they may differ byte-for-byte from any single upstream
while denoting the same value; integrity-bearing fields (@dist.integrity@,
@dist.tarball@ up to the rewrite's own prefix) are relayed raw and untouched. The
served bytes get our __own ETag__, since a merged\/filtered body matches no single
upstream's.
-}
module Ecluse.Core.Server.Pipeline.Packument (
    servePackument,
    headPackument,
    withPublicMetadataClient,

    -- * The derived validator (exported for its unit spec)
    packumentETag,
) where

import Crypto.Hash (Context, SHA256, hashFinalize, hashInit, hashUpdates)
import Data.Aeson (Value (Object))
import Data.Aeson qualified as Aeson
import Data.Aeson.Text (encodeToLazyText)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Katip (KatipContext, Severity (DebugS, InfoS, WarningS), katipAddContext, logFM, ls, sl)
import Network.HTTP.Client (Manager)
import Network.HTTP.Types (ResponseHeaders, Status, hContentLength, mkStatus, status200)
import Network.Wai (Request, Response, ResponseReceived, requestHeaders)
import UnliftIO (concurrently, withRunInIO)
import UnliftIO.Exception (tryAny)

import Ecluse.Core.Credential (Secret)

import Ecluse.Core.Package (
    InvalidEntry (invalidKey, invalidKind, invalidReason, invalidValue),
    InvalidEntryKind (InvalidDistTag, InvalidPublishTime, InvalidVersionManifest),
    PackageInfo (infoVersions),
    PackageName,
    renderPackageName,
 )
import Ecluse.Core.Package.Filter (filterPlanFromDecisions, fpDecisions, fpSurvivors, restrictToSurvivors)
import Ecluse.Core.Package.Integrity (
    MinTrustedIntegrity,
 )
import Ecluse.Core.Package.Merge (
    MergePlan (mpSurvivors),
    Provenance (GatedSource, TrustedSource),
    SourceId,
    mergePackuments,
 )
import Ecluse.Core.Registry.Metadata (
    ContentDigest,
    Manifest (manifestDigest, manifestInfo, manifestRaw),
    MetadataClient (fetchFullManifest),
    MetadataError (MetadataBoundExceeded, MetadataNameMismatch, MetadataUndecodable),
    digestBytes,
 )
import Ecluse.Core.Rules (evalRules)
import Ecluse.Core.Rules.Types (Decision, EvalContext (EvalContext))
import Ecluse.Core.Security (
    LimitError (BodyTooLarge, TooDeeplyNested, TooManyVersions),
    Limits,
 )
import Ecluse.Core.Server.Admission (withServeAdmission)
import Ecluse.Core.Server.Cache (Source (Source), resolveAssembled)
import Ecluse.Core.Server.Conditional (Conditional (Modified, NotModified), ETag, etagHeader, evaluateETag, mkStrongETag, renderETag)
import Ecluse.Core.Server.Context (
    Handler,
    MountBinding (bindingPackumentDeps, bindingRenderer),
    PackumentDeps (..),
    ServeRuntime (..),
    ctxMount,
    ctxRuntime,
 )
import Ecluse.Core.Server.Metadata (ManifestCaching (Cached, Uncached))
import Ecluse.Core.Server.Pipeline.Internal (
    admitByIntegrity,
    evalTier,
    logDecodeFailure,
    logNameMismatch,
    packumentServeDecision,
    recordDenials,
    recordEffectfulFailures,
 )
import Ecluse.Core.Server.Pipeline.Shared
import Ecluse.Core.Server.Response (
    MountRenderer,
    PackumentStatus (PackumentBadGateway, PackumentForbidden, PackumentOk, PackumentServerError, PackumentUnavailable),
    RejectReason (Unavailable, UpstreamInvalid),
    Rejection (Rejection, rejectionMessage),
    RetryAfter (RetryAfter),
    ServeDecision (Admit, Reject),
    Transience (WillResolve),
    packumentStatus,
    packumentStatusCode,
    renderError,
    serveDecisionOf,
 )
import Ecluse.Core.Telemetry.Metrics qualified as Metric
import Ecluse.Core.Telemetry.Record (MetricsPort (..), timedSeconds)
import Ecluse.Core.Telemetry.Span (TracingPort, spanPackumentGate)

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

The mount's 'PackumentDeps' and error renderer are read from the matched
'MountBinding' in context, not threaded as arguments. When the mount has no
packument-serve dependencies wired, the route is recognised but not served -- a
@501@ in the mount's surface -- rather than fabricating a result.

With dependencies wired: the edge token, if configured, is validated before any
upstream is touched. Then the private and public upstreams are fetched
__concurrently__ -- the client's credential forwarded to the private origin, the public
origin anonymous -- each parse failure or unavailable upstream degrading to a missing
contribution rather than an error. Private versions are trusted as-is; public
versions are gated through the rules and the structural filter (the 'FilterPlan');
the surviving sets are merged ('mergePackuments') and the 'MergePlan' assembled
onto the raw upstream @Value@s to build the served body,
which is then answered against the client's conditional request with our own ETag.
When nothing survives, the status follows the most recoverable cause via
'packumentStatus'. An origin whose self-reported packument name disagrees with the
route is validated out -- dropped as untrusted for this request and logged -- so a
single misreporting upstream never denies a package another upstream serves; when
that leaves __no__ valid origin, the request is a @502@ (a responding upstream
returned an invalid response), distinct from a genuine absence. Every refusal -- the
edge @401@ and the no-survivors @403@\/@503@\/@502@\/@500@ -- is rendered through the
mount's 'MountRenderer'.
-}
servePackument ::
    PackageName ->
    Request ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
servePackument :: PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
servePackument = PackumentServe
-> PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
packumentWith PackumentServe
PackumentFull

{- | Serve a @HEAD \/{pkg}@ packument request: the __identical pipeline and gating__ as
'servePackument' -- the same fetch, merge, filter, rule decision, and no-survivors
status -- answered with the __identical status and headers__ as the @GET@ (the would-be
merged body's @Content-Length@ and the own @ETag@ the conditional-request machinery
computes), but with the body suppressed ('bodiless'), as HTTP semantics require of a
@HEAD@ reply.

A packument body is assembled __locally__ (a metadata fetch plus the cross-upstream
merge), so -- unlike the tarball @HEAD@ ('headTarball') -- answering it pumps __no
artifact body__ and carries no egress-amplification risk: this is the HTTP-correctness
half of the explicit-@HEAD@ handling, not the DoS lever the tarball path closes. The
merged body is still materialised, to size it and compute its @ETag@; only the bytes
are withheld from the reply.
-}
headPackument ::
    PackageName ->
    Request ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
headPackument :: PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
headPackument PackageName
name Request
request Response -> IO ResponseReceived
respond =
    PackumentServe
-> PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
packumentWith PackumentServe
PackumentHead PackageName
name 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 packument serve mode threaded through the handler: a full @GET@ that serves the
merged body, or a @HEAD@ that answers the identical status and headers with the body
suppressed. It changes exactly one thing in the pipeline -- whether the @200@ success
path stamps the would-be body's @Content-Length@ (a @HEAD@ does, so a client sees the
framing a @GET@ would; a @GET@ leaves that to the serving layer, which frames the body
it actually writes). The body itself is withheld uniformly by the 'bodiless' wrapper
'headPackument' applies, and the gating is byte-for-byte identical between the two. -}
data PackumentServe
    = -- A @GET@: serve the merged packument body.
      PackumentFull
    | -- A @HEAD@: serve the identical status and headers (the would-be body's
      -- @Content-Length@ and the own @ETag@) with no body.
      PackumentHead

-- Dispatch shared by 'servePackument' and 'headPackument': resolve the mount's
-- dependencies (or the recognised-but-unserved @501@ stub) and serve in the given mode.
packumentWith ::
    PackumentServe ->
    PackageName ->
    Request ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
packumentWith :: PackumentServe
-> PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
packumentWith PackumentServe
mode PackageName
name 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 -> PackumentServe
-> MountRenderer
-> PackumentDeps
-> PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
serveWithDeps PackumentServe
mode MountRenderer
renderer PackumentDeps
deps PackageName
name Request
request Response -> IO ResponseReceived
respond

-- Serve a packument once the mount's dependencies are known: fetch, gate, merge,
-- and answer -- the credential-authority and merge logic the module header
-- describes. The request runtime is read from the request context. The
-- 'PackumentServe' mode is threaded to the success path so a @HEAD@ stamps the
-- would-be body's @Content-Length@ (the 'bodiless' wrapper withholds the bytes).
serveWithDeps ::
    PackumentServe ->
    MountRenderer ->
    PackumentDeps ->
    PackageName ->
    Request ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
serveWithDeps :: PackumentServe
-> MountRenderer
-> PackumentDeps
-> PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
serveWithDeps PackumentServe
mode MountRenderer
renderer PackumentDeps
deps PackageName
name 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
        withServeAdmission (srMetrics rt) (srAdmission rt) (serveAdmitted rt) >>= \case
            Just ResponseReceived
received -> ResponseReceived -> Handler ResponseReceived
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
received
            Maybe ResponseReceived
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 (ServeRuntime -> MetricsPort
srMetrics ServeRuntime
rt) Decision
Metric.Unavailable
                Response -> IO ResponseReceived
respond (MountRenderer -> Response
serveOverloaded MountRenderer
renderer)
  where
    -- The client's bearer, scanned out of the headers once: the edge gate compares
    -- it and the private-origin fetch forwards it.
    clientToken :: Maybe Secret
clientToken = Request -> Maybe Secret
forwardedToken Request
request

    serveAdmitted :: ServeRuntime -> Handler ResponseReceived
serveAdmitted ServeRuntime
rt = do
        Severity -> LogStr -> Handler ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
InfoS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"serving packument request for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
name))
        let metrics :: MetricsPort
metrics = ServeRuntime -> MetricsPort
srMetrics ServeRuntime
rt
        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)
        (privResult, pubResult) <-
            concurrently
                (fetchPrivateOrigin deps rt clientToken name)
                (fetchPublicOrigin deps rt name)
        (public, publicExclusions) <- liftIO (gatePublic (srTracing rt) metrics deps name evalCtx (originManifest pubResult))
        let (private, privateExclusions) = admitTrusted (pdMinTrustedIntegrity deps) (originManifest privResult)
            sources = [Maybe Contribution] -> [Contribution]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Contribution
private, Maybe Contribution
public]
        case packumentPlan sources of
            Just MergePlan
plan -> 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)
                ServeRuntime
-> [Contribution] -> MergePlan -> Handler ResponseReceived
forall {m :: * -> *}.
KatipContext m =>
ServeRuntime -> [Contribution] -> MergePlan -> m ResponseReceived
answerConditional ServeRuntime
rt [Contribution]
sources MergePlan
plan
            Maybe MergePlan
Nothing -> do
                let decisions :: [ServeDecision]
decisions = OriginResult -> OriginResult -> [ServeDecision] -> [ServeDecision]
collectDecisions OriginResult
privResult OriginResult
pubResult ([ServeDecision]
privateExclusions [ServeDecision] -> [ServeDecision] -> [ServeDecision]
forall a. Semigroup a => a -> a -> a
<> [ServeDecision]
publicExclusions)
                IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> Decision -> IO ()
mpServeDecision MetricsPort
metrics ([ServeDecision] -> Decision
packumentServeDecision [ServeDecision]
decisions))
                IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> [ServeDecision] -> IO ()
recordDenials MetricsPort
metrics [ServeDecision]
decisions)
                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 -> PackumentDeps -> [ServeDecision] -> Response
noSurvivors MountRenderer
renderer PackumentDeps
deps [ServeDecision]
decisions))

    -- The validator is derived from the serve's inputs, so the conditional
    -- request is answered BEFORE any assembly: a 304 costs the fetches and
    -- the plan, never the document rebuild, encode, or an output hash.
    answerConditional :: ServeRuntime -> [Contribution] -> MergePlan -> m ResponseReceived
answerConditional ServeRuntime
rt [Contribution]
sources MergePlan
plan = do
        let etag :: ETag
etag = Text
-> PackageName -> [(Provenance, ContentDigest, [Text])] -> ETag
packumentETag (PackumentDeps -> Text
pdMountBaseUrl PackumentDeps
deps) PackageName
name ((Contribution -> (Provenance, ContentDigest, [Text]))
-> [Contribution] -> [(Provenance, ContentDigest, [Text])]
forall a b. (a -> b) -> [a] -> [b]
map Contribution -> (Provenance, ContentDigest, [Text])
fingerprintPiece [Contribution]
sources)
        case RequestHeaders -> ETag -> Conditional
evaluateETag (Request -> RequestHeaders
requestHeaders Request
request) ETag
etag of
            NotModified ETag
matched -> do
                Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
DebugS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"packument unchanged for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (304, unassembled)"))
                IO ResponseReceived -> m ResponseReceived
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Response -> IO ResponseReceived
respond (ETag -> Response
notModifiedResponse ETag
matched))
            Modified ETag
fresh -> do
                Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
DebugS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"serving packument for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
name))
                bytes <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ServeRuntime
-> PackumentDeps
-> [Contribution]
-> MergePlan
-> ETag
-> IO ByteString
servedBytes ServeRuntime
rt PackumentDeps
deps [Contribution]
sources MergePlan
plan ETag
fresh)
                liftIO (respond (packumentResponse mode fresh bytes))

-- A recognised-but-unserved packument route: a @501@ in the mount's surface, for a
-- mount whose packument-serve dependencies are not wired. The decision to serve or
-- stub is the handler's, so the routing layer need not re-derive it.

{- A successfully resolved upstream contribution: the parsed packument used to
decide, alongside the raw @Value@ that is edited in place to serve, and the
origin body's 'ContentDigest' for the derived validator. Pairing the views is
the decision-surface\/served-surface contract -- every stage carries the raw
@Value@ next to the typed view so losslessness survives the pipeline. -}
data Contribution = Contribution
    { Contribution -> Provenance
srcProvenance :: Provenance
    , Contribution -> PackageInfo
srcInfo :: PackageInfo
    , Contribution -> Value
srcValue :: Value
    , Contribution -> ContentDigest
srcDigest :: ContentDigest
    }

{- One source's slice of the derived validator: its provenance, its origin body's
digest, and the version keys that actually survived its gate -- together with the
mount base URL and package name, exactly the inputs the assembled document is a
deterministic function of (the plan itself derives from these). -}
fingerprintPiece :: Contribution -> (Provenance, ContentDigest, [Text])
fingerprintPiece :: Contribution -> (Provenance, ContentDigest, [Text])
fingerprintPiece Contribution
s = (Contribution -> Provenance
srcProvenance Contribution
s, Contribution -> ContentDigest
srcDigest Contribution
s, Map Text PackageDetails -> [Text]
forall k a. Map k a -> [k]
Map.keys (PackageInfo -> Map Text PackageDetails
infoVersions (Contribution -> PackageInfo
srcInfo Contribution
s)))

{- The outcome of resolving one upstream origin for a packument, beyond the
plain "resolved or not" the merge consumes: a name mismatch is kept distinct from a
plain non-resolution so the no-valid-origin terminal status can render a @502@ (a
responding upstream returned a packument for a different package) apart from a
transient outage or a genuine absence. -}
data OriginResult
    = -- | A packument that decoded and whose self-reported name matched the request.
      OriginResolved Manifest
    | {- | The origin answered, but its packument self-reported a name for a /different/
      package -- dropped as untrusted for this request, and a @502@ signal when no
      origin is valid.
      -}
      OriginNameMismatch
    | {- | The origin did not yield a usable packument -- unreachable, undecodable, or a
      genuine absence -- the existing degrade (no contribution).
      -}
      OriginUnresolved

-- The resolved manifest an origin contributed, if any. A name mismatch and a plain
-- non-resolution alike contribute no document to the merge.
originManifest :: OriginResult -> Maybe Manifest
originManifest :: OriginResult -> Maybe Manifest
originManifest = \case
    OriginResolved Manifest
manifest -> Manifest -> Maybe Manifest
forall a. a -> Maybe a
Just Manifest
manifest
    OriginResult
OriginNameMismatch -> Maybe Manifest
forall a. Maybe a
Nothing
    OriginResult
OriginUnresolved -> Maybe Manifest
forall a. Maybe a
Nothing

{- Classify a per-origin full-manifest fetch into an 'OriginResult'. A genuine
transport\/async fault (the 'tryAny' channel) and a 'MetadataError' degrade alike yield
no document, but a 'MetadataNameMismatch' is kept distinct as 'OriginNameMismatch' so the
no-valid-origin terminal status can render a @502@ (a responding upstream answered for a
different package) apart from a transient outage, an undecodable body, or a bound breach. -}
originResultOf :: Either SomeException (Either MetadataError Manifest) -> OriginResult
originResultOf :: Either SomeException (Either MetadataError Manifest)
-> OriginResult
originResultOf = \case
    Left SomeException
_ -> OriginResult
OriginUnresolved
    Right (Left (MetadataNameMismatch Text
_)) -> OriginResult
OriginNameMismatch
    Right (Left MetadataError
_) -> OriginResult
OriginUnresolved
    Right (Right Manifest
manifest) -> Manifest -> OriginResult
OriginResolved Manifest
manifest

{- Resolve the private (trusted) upstream origin, __uncached__, forwarding the client's
own credential (the default @passthrough@ posture). Returns its coherent (parsed
packument, raw @Value@) pair -- or 'Nothing' when the origin is unavailable or its body
does not parse. A failed fetch is a degraded contribution, not an error: the merge
serves the best-effort union of whatever resolved (partial-upstream availability).

Under @passthrough@ the private upstream is the per-client authority for who may read
what, so its metadata is __not__ shared across clients: it is fetched and parsed on
__every__ request with that client's own forwarded token, so the upstream re-authorises
each client itself. Caching it would key on the base URL alone (no credential
dimension), so within the TTL one client's cache hit would skip the fetch and serve
another client's private document -- bypassing the upstream's authorisation. The private
origin is therefore deliberately kept out of the metadata cache; only the anonymous
public origin is cached. (How a non-@passthrough@ strategy can instead share the private
origin safely is the serve-time authorisation it adds -- see
@docs\/architecture\/access-model.md@.) -}
fetchPrivateOrigin :: PackumentDeps -> ServeRuntime -> Maybe Secret -> PackageName -> Handler OriginResult
fetchPrivateOrigin :: PackumentDeps
-> ServeRuntime
-> Maybe Secret
-> PackageName
-> Handler OriginResult
fetchPrivateOrigin PackumentDeps
deps ServeRuntime
rt Maybe Secret
token PackageName
name = do
    Severity -> LogStr -> Handler ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
DebugS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"fetching private origin for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
name))
    resolved <-
        Handler (Either MetadataError Manifest)
-> Handler (Either SomeException (Either MetadataError Manifest))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (Handler (Either MetadataError Manifest)
 -> Handler (Either SomeException (Either MetadataError Manifest)))
-> Handler (Either MetadataError Manifest)
-> Handler (Either SomeException (Either MetadataError Manifest))
forall a b. (a -> b) -> a -> b
$
            ServeRuntime
-> PackumentDeps
-> Upstream
-> ManifestCaching
-> Limits
-> Manager
-> Text
-> Maybe Secret
-> (MetadataClient -> IO (Either MetadataError Manifest))
-> Handler (Either MetadataError Manifest)
forall a.
ServeRuntime
-> PackumentDeps
-> Upstream
-> ManifestCaching
-> Limits
-> Manager
-> Text
-> Maybe Secret
-> (MetadataClient -> IO a)
-> Handler a
withMetadataClient ServeRuntime
rt PackumentDeps
deps Upstream
Metric.Private ManifestCaching
Uncached (PackumentDeps -> Limits
pdLimits PackumentDeps
deps) (ServeRuntime -> Manager
srPrivateManager ServeRuntime
rt) (PackumentDeps -> Text
pdPrivateBaseUrl PackumentDeps
deps) Maybe Secret
token ((MetadataClient -> IO (Either MetadataError Manifest))
 -> Handler (Either MetadataError Manifest))
-> (MetadataClient -> IO (Either MetadataError Manifest))
-> Handler (Either MetadataError Manifest)
forall a b. (a -> b) -> a -> b
$ \MetadataClient
client ->
                MetadataClient -> PackageName -> IO (Either MetadataError Manifest)
fetchFullManifest MetadataClient
client PackageName
name
    pure (originResultOf resolved)

{- Resolve the public (gated, anonymous) upstream origin through the metadata cache,
keyed by the origin's base URL as its 'Source', returning its coherent (parsed
packument, raw @Value@) pair -- or 'Nothing' when the origin is unavailable or its body
does not parse. A failed fetch is a degraded contribution, not an error.

The public origin is anonymous (no client credential), so a single cached entry serves
every client without crossing any trust boundary -- there is no per-client authority
to preserve, only one shared anonymous document. A hit returns the cached pair
(typed view and the exact bytes it was decoded from), so the served document and the
decision over it stay coherent across the TTL, and concurrent resolutions of a
popular package __collapse to one upstream call__ -- as does the tarball gate's
single-version read, which shares this very cache entry ('fetchVersionMetadata'). -}
fetchPublicOrigin :: PackumentDeps -> ServeRuntime -> PackageName -> Handler OriginResult
fetchPublicOrigin :: PackumentDeps
-> ServeRuntime -> PackageName -> Handler OriginResult
fetchPublicOrigin PackumentDeps
deps ServeRuntime
rt PackageName
name = do
    Severity -> LogStr -> Handler ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
DebugS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"fetching public origin for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
name))
    resolved <-
        Handler (Either MetadataError Manifest)
-> Handler (Either SomeException (Either MetadataError Manifest))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (Handler (Either MetadataError Manifest)
 -> Handler (Either SomeException (Either MetadataError Manifest)))
-> Handler (Either MetadataError Manifest)
-> Handler (Either SomeException (Either MetadataError Manifest))
forall a b. (a -> b) -> a -> b
$
            ServeRuntime
-> PackumentDeps
-> Text
-> (MetadataClient -> IO (Either MetadataError Manifest))
-> Handler (Either MetadataError Manifest)
forall a.
ServeRuntime
-> PackumentDeps -> Text -> (MetadataClient -> IO a) -> Handler a
withPublicMetadataClient ServeRuntime
rt PackumentDeps
deps (PackumentDeps -> Text
pdPublicBaseUrl PackumentDeps
deps) ((MetadataClient -> IO (Either MetadataError Manifest))
 -> Handler (Either MetadataError Manifest))
-> (MetadataClient -> IO (Either MetadataError Manifest))
-> Handler (Either MetadataError Manifest)
forall a b. (a -> b) -> a -> b
$ \MetadataClient
client ->
                MetadataClient -> PackageName -> IO (Either MetadataError Manifest)
fetchFullManifest MetadataClient
client PackageName
name
    pure (originResultOf resolved)

{- Construct a per-request read handle for one origin and run an action over it, with the
ambient @katip@ context captured into the handle's failure log.

The handle's operations run the fetch in plain 'IO' (the public origin's cache leader runs
under @mask@); 'withRunInIO' discharges the 'Handler' logs to 'IO' while capturing the
request's trace-correlated context, so a breach\/decode\/name-mismatch warning, or the
dropped-entry warning a successful-but-degraded projection emits ('logInvalidEntries'),
still rides that context. The npm origin's credential posture, manager, base URL, and
response budget are the per-fetch 'NpmClientConfig'; the 'ManifestCaching' decides whether
the origin resolves through the shared metadata cache.

Every response bound (security.md invariant 4) is enforced inside the handle's fetch
against the mount's 'Limits' budget -- a body-size, nesting-depth, or version-count breach
becomes a 'MetadataBoundExceeded', logged once at a 'WarningS' (naming the package and the
ceiling crossed) before it degrades the contribution fail-closed, so an operator can tell a
hostile\/oversized upstream from an ordinary parse failure. -}
withMetadataClient ::
    ServeRuntime ->
    PackumentDeps ->
    Metric.Upstream ->
    ManifestCaching ->
    Limits ->
    Manager ->
    Text ->
    Maybe Secret ->
    (MetadataClient -> IO a) ->
    Handler a
withMetadataClient :: forall a.
ServeRuntime
-> PackumentDeps
-> Upstream
-> ManifestCaching
-> Limits
-> Manager
-> Text
-> Maybe Secret
-> (MetadataClient -> IO a)
-> Handler a
withMetadataClient ServeRuntime
rt PackumentDeps
deps Upstream
upstream ManifestCaching
caching Limits
limits Manager
manager Text
baseUrl Maybe Secret
token MetadataClient -> IO a
k =
    ((forall a. Handler a -> IO a) -> IO a) -> Handler a
forall b. ((forall a. Handler a -> IO a) -> IO b) -> Handler b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. Handler a -> IO a) -> IO a) -> Handler a)
-> ((forall a. Handler a -> IO a) -> IO a) -> Handler a
forall a b. (a -> b) -> a -> b
$ \forall a. Handler a -> IO a
runInIO ->
        MetadataClient -> IO a
k (MetadataClient -> IO a) -> MetadataClient -> IO a
forall a b. (a -> b) -> a -> b
$
            PackumentDeps
-> TracingPort
-> MetricsPort
-> Upstream
-> ManifestCaching
-> (PackageName -> MetadataError -> IO ())
-> (PackageName -> [InvalidEntry] -> IO ())
-> (PackageName -> IO ())
-> Limits
-> Manager
-> Text
-> Maybe Secret
-> MetadataClient
pdNewMetadataClient
                PackumentDeps
deps
                (ServeRuntime -> TracingPort
srTracing ServeRuntime
rt)
                (ServeRuntime -> MetricsPort
srMetrics ServeRuntime
rt)
                Upstream
upstream
                ManifestCaching
caching
                (\PackageName
nm MetadataError
err -> Handler () -> IO ()
forall a. Handler a -> IO a
runInIO (PackageName -> Text -> MetadataError -> Handler ()
logMetadataFailure PackageName
nm Text
baseUrl MetadataError
err))
                (\PackageName
nm [InvalidEntry]
entries -> Handler () -> IO ()
forall a. Handler a -> IO a
runInIO (PackageName -> Text -> [InvalidEntry] -> Handler ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> [InvalidEntry] -> m ()
logInvalidEntries PackageName
nm Text
baseUrl [InvalidEntry]
entries))
                (\PackageName
nm -> Handler () -> IO ()
forall a. Handler a -> IO a
runInIO (Severity -> LogStr -> Handler ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
DebugS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"fetching packument from origin for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
nm))))
                Limits
limits
                Manager
manager
                Text
baseUrl
                Maybe Secret
token

{- The public origin's read handle: anonymous (no token), resolved through the shared
metadata cache under the base URL's 'Source'. Both the packument fetch ('fetchFullManifest')
and the tarball gate's single-version read ('fetchVersionMetadata') go through this handle,
so they share one cache entry. -}
withPublicMetadataClient :: ServeRuntime -> PackumentDeps -> Text -> (MetadataClient -> IO a) -> Handler a
withPublicMetadataClient :: forall a.
ServeRuntime
-> PackumentDeps -> Text -> (MetadataClient -> IO a) -> Handler a
withPublicMetadataClient ServeRuntime
rt PackumentDeps
deps Text
baseUrl =
    ServeRuntime
-> PackumentDeps
-> Upstream
-> ManifestCaching
-> Limits
-> Manager
-> Text
-> Maybe Secret
-> (MetadataClient -> IO a)
-> Handler a
forall a.
ServeRuntime
-> PackumentDeps
-> Upstream
-> ManifestCaching
-> Limits
-> Manager
-> Text
-> Maybe Secret
-> (MetadataClient -> IO a)
-> Handler a
withMetadataClient ServeRuntime
rt PackumentDeps
deps Upstream
Metric.Public (MetadataCache -> Source -> ManifestCaching
Cached (ServeRuntime -> MetadataCache
srMetadataCache ServeRuntime
rt) (Text -> Source
Source Text
baseUrl)) (PackumentDeps -> Limits
pdLimits PackumentDeps
deps) (ServeRuntime -> Manager
srPublicManager ServeRuntime
rt) Text
baseUrl Maybe Secret
forall a. Maybe a
Nothing

{- Log a per-origin metadata-fetch failure at the point and severity it has always been
logged: a response-bound breach names the ceiling crossed ('logBreach'); an undecodable
body is the silent-guard decode log ('logDecodeFailure'); a self-reported /different/ name
is the name-mismatch log ('logNameMismatch'). Invoked once per real fetch, inside the
single-flight leader, in the request's context. -}
logMetadataFailure :: PackageName -> Text -> MetadataError -> Handler ()
logMetadataFailure :: PackageName -> Text -> MetadataError -> Handler ()
logMetadataFailure PackageName
name Text
baseUrl = \case
    MetadataBoundExceeded LimitError
err -> PackageName -> LimitError -> Handler ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> LimitError -> m ()
logBreach PackageName
name LimitError
err
    MetadataError
MetadataUndecodable -> PackageName -> Handler ()
forall (m :: * -> *). KatipContext m => PackageName -> m ()
logDecodeFailure PackageName
name
    MetadataNameMismatch Text
reported -> PackageName -> Text -> Text -> Handler ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> Text -> m ()
logNameMismatch PackageName
name Text
baseUrl Text
reported

{- Log a response-bound breach at 'WarningS' before the contribution is degraded
fail-closed, so an operator can distinguish a bound breach (a hostile\/oversized
upstream, or a too-tight cap) from an ordinary parse failure or upstream outage. The
structured payload names the package, which @bound@ was crossed, and the observed
value against its @cap@ -- the high-cardinality identifiers that belong on the log
line, not a metric label. Emitted through the ambient @katip@ context (the request's,
so the line carries its trace-correlation @dd@), under the @ecluse@ namespace the rest
of the stream uses. -}
logBreach :: (KatipContext m) => PackageName -> LimitError -> m ()
logBreach :: forall (m :: * -> *).
KatipContext m =>
PackageName -> LimitError -> m ()
logBreach PackageName
name LimitError
err =
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message)
  where
    -- The package the refused document was for, plus the breach detail, as the
    -- structured @data@ object on the line.
    payload :: SimpleLogPayload
payload =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineModule
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"bound" Text
boundName
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"observed" Text
observed
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"cap" Text
cap

    -- A human-readable one-line summary; the structured fields carry the detail.
    message :: Text
    message :: Text
message = Text
"refused an upstream metadata document: it exceeded the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
boundName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" response bound (observed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
observed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", cap " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cap Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

    -- Which ceiling, the observed value, and the cap -- pulled from the typed error so
    -- the three are always consistent with what was enforced.
    boundName :: Text
    observed :: Text
    cap :: Text
    (Text
boundName, Text
observed, Text
cap) = case LimitError
err of
        BodyTooLarge Int
c -> (Text
"body-size", Text
"over " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes", Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes")
        TooManyVersions Int
seen Int
c -> (Text
"version-count", Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
seen, Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c)
        TooDeeplyNested Int
c -> (Text
"nesting-depth", Text
"over " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" levels", Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" levels")

{- Log the malformed packument entries an upstream served that the projection dropped
rather than failing the whole document on, at 'WarningS', so an operator can see that an
upstream served a malformed entry, which kind (a version manifest, a dist-tag, or a
per-version publish time), and __the raw value it sent__. The structured payload names the
package, the per-kind drop counts, and a bounded sample of the dropped entries each
rendering its raw 'Aeson.Value' (truncated if large, and capped to 'maxRenderedDrops'
entries so a flood of drops cannot bloat the line). The dropped versions are still served
minus those entries (graceful degradation), so this is an observability signal, not a
refusal. Emitted once per real fetch (inside the cache leader, so a coalesced follower
never re-logs) through the request's @katip@ context. The caller guards on a non-empty
list, so this never logs for a clean document. -}
logInvalidEntries :: (KatipContext m) => PackageName -> Text -> [InvalidEntry] -> m ()
logInvalidEntries :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> [InvalidEntry] -> m ()
logInvalidEntries PackageName
name Text
baseUrl [InvalidEntry]
entries =
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message)
  where
    payload :: SimpleLogPayload
payload =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineModule
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"upstream" Text
baseUrl
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"droppedVersionManifests" (InvalidEntryKind -> Int
countOf InvalidEntryKind
InvalidVersionManifest)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"droppedDistTags" (InvalidEntryKind -> Int
countOf InvalidEntryKind
InvalidDistTag)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"droppedPublishTimes" (InvalidEntryKind -> Int
countOf InvalidEntryKind
InvalidPublishTime)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"droppedEntries" ((InvalidEntry -> Text) -> [InvalidEntry] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map InvalidEntry -> Text
renderDroppedEntry (Int -> [InvalidEntry] -> [InvalidEntry]
forall a. Int -> [a] -> [a]
take Int
maxRenderedDrops [InvalidEntry]
entries))

    countOf :: InvalidEntryKind -> Int
    countOf :: InvalidEntryKind -> Int
countOf InvalidEntryKind
kind = (Int -> InvalidEntry -> Int) -> Int -> [InvalidEntry] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
acc InvalidEntry
e -> if InvalidEntry -> InvalidEntryKind
invalidKind InvalidEntry
e InvalidEntryKind -> InvalidEntryKind -> Bool
forall a. Eq a => a -> a -> Bool
== InvalidEntryKind
kind then Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
acc) Int
0 [InvalidEntry]
entries

    message :: Text
    message :: Text
message =
        Text
"dropped " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show ([InvalidEntry] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InvalidEntry]
entries) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" malformed entr" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
plural Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from an upstream packument (the rest is served)"
    plural :: Text
plural = if [InvalidEntry] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InvalidEntry]
entries Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"y" else Text
"ies"

-- One dropped entry rendered for the operator: its kind, key, reason, and the raw
-- value the upstream sent (truncated), so the actual offending bytes are visible.
renderDroppedEntry :: InvalidEntry -> Text
renderDroppedEntry :: InvalidEntry -> Text
renderDroppedEntry InvalidEntry
e =
    InvalidEntryKind -> Text
renderInvalidKind (InvalidEntry -> InvalidEntryKind
invalidKind InvalidEntry
e)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> InvalidEntry -> Text
invalidKey InvalidEntry
e
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
truncatedValue (InvalidEntry -> Value
invalidValue InvalidEntry
e)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> InvalidEntry -> Text
invalidReason InvalidEntry
e
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

renderInvalidKind :: InvalidEntryKind -> Text
renderInvalidKind :: InvalidEntryKind -> Text
renderInvalidKind = \case
    InvalidEntryKind
InvalidVersionManifest -> Text
"version-manifest"
    InvalidEntryKind
InvalidDistTag -> Text
"dist-tag"
    InvalidEntryKind
InvalidPublishTime -> Text
"publish-time"

-- The raw value as compact JSON, truncated to 'maxRenderedValueChars' (only that many
-- characters are ever forced, so a huge value never balloons the log line).
truncatedValue :: Value -> Text
truncatedValue :: Value -> Text
truncatedValue Value
v =
    let rendered :: Text
rendered = LazyText -> Text
TL.toStrict (Int64 -> LazyText -> LazyText
TL.take (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxRenderedValueChars Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1) (Value -> LazyText
forall a. ToJSON a => a -> LazyText
encodeToLazyText Value
v))
     in if Text -> Int
T.length Text
rendered Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxRenderedValueChars
            then Int -> Text -> Text
T.take Int
maxRenderedValueChars Text
rendered Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"…"
            else Text
rendered

-- How many dropped entries the drop-tracking log renders in full, and how many characters
-- of each raw value, so an unbounded flood of malformed entries (or one huge value) cannot
-- bloat a single log line. The per-kind counts in the payload still report the full totals.
maxRenderedDrops :: Int
maxRenderedDrops :: Int
maxRenderedDrops = Int
20

maxRenderedValueChars :: Int
maxRenderedValueChars :: Int
maxRenderedValueChars = Int
200

-- The @module@ tag this module's breach log carries -- the operator-facing log filter
-- key, held stable as the current value rather than the source module path, so an
-- operator's saved filter keeps matching across the move into ecluse-core (the only
-- change to these lines is the trace-correlation @dd@ the ambient context adds). The
-- decode-failure log lives in "Ecluse.Core.Server.Pipeline.Internal", tagged likewise.
pipelineModule :: Text
pipelineModule :: Text
pipelineModule = Text
"Ecluse.Server.Pipeline"

{- Apply the __trusted integrity floor__ to a private (trusted) contribution before it
enters the merge, returning the surviving 'Contribution' (if any version survived) and the
per-version exclusions for the dropped ones (for the no-survivors status). This is the
trusted-path mirror of 'gatePublic': a private version whose strongest digest is below the
trusted floor ('pdMinTrustedIntegrity') is dropped from the served listing, so by default
(floor = SHA-256) a SHA-1-only or hashless private version is not listed, while an operator
who loosens the trusted floor admits it again. Trusted versions stay __unfiltered by the
rules__ (the trust split is the caller's); only the integrity floor applies. The raw
@Value@ is kept whole -- the merge replays only surviving keys onto it, so a dropped version
is never taken from it; tarball URLs are rewritten at assembly, uniformly across sources. -}
admitTrusted :: MinTrustedIntegrity -> Maybe Manifest -> (Maybe Contribution, [ServeDecision])
admitTrusted :: MinTrustedIntegrity
-> Maybe Manifest -> (Maybe Contribution, [ServeDecision])
admitTrusted MinTrustedIntegrity
minTrusted = \case
    Maybe Manifest
Nothing -> (Maybe Contribution
forall a. Maybe a
Nothing, [])
    Just Manifest
manifest ->
        let (PackageInfo
admissible, [ServeDecision]
integrityRefusals) =
                MinTrustedIntegrity
-> ServeDecision
-> ServeDecision
-> PackageInfo
-> (PackageInfo, [ServeDecision])
forall floor.
IntegrityFloor floor =>
floor
-> ServeDecision
-> ServeDecision
-> PackageInfo
-> (PackageInfo, [ServeDecision])
admitByIntegrity MinTrustedIntegrity
minTrusted ServeDecision
trustedIntegrityBelowFloor ServeDecision
trustedIntegrityMissing (Manifest -> PackageInfo
manifestInfo Manifest
manifest)
         in if Map Text PackageDetails -> Bool
forall k a. Map k a -> Bool
Map.null (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
admissible)
                then (Maybe Contribution
forall a. Maybe a
Nothing, [ServeDecision]
integrityRefusals)
                else (Contribution -> Maybe Contribution
forall a. a -> Maybe a
Just (Provenance -> PackageInfo -> Value -> ContentDigest -> Contribution
Contribution Provenance
TrustedSource PackageInfo
admissible (Manifest -> Value
manifestRaw Manifest
manifest) (Manifest -> ContentDigest
manifestDigest Manifest
manifest)), [ServeDecision]
integrityRefusals)

{- Gate a public-upstream contribution through the rules engine and the structural
filter, returning the surviving 'Contribution' (if any survived) and the per-version
exclusion outcomes (for the no-survivors status when nothing survives anywhere).

A public origin that did not resolve contributes nothing and no exclusions. A resolved
origin first has the __integrity-floor admission policy__ applied: any version whose
strongest digest does not meet the configured floor ('pdMinIntegrity') is dropped from
the gated set up front ('admitByIntegrity'), so a below-floor public version is never
listed (a client cannot fetch it -- the artifact gate would refuse it anyway) and never
contributes its fingerprint to the merge. The remaining versions are decided by the
rules engine ('Ecluse.Core.Rules.evalRules' -- the boot order walked to the first decisive
result), the resulting decisions handed to the agnostic
'filterPlanFromDecisions', and the plan consumed directly: a plan with survivors
yields a gated 'Contribution' -- the typed view restricted to the survivors beside
the __unrestricted raw @Value@__ (the assembly takes only plan-surviving version
objects from it, so restricting the raw document here would rebuild a many-version
object only for the assembly to rebuild it again); a plan with no survivors yields
no contribution and the per-version 'ServeDecision's, each excluded
version's decision projected (a fail-closed 'Ecluse.Core.Rules.Types.Undecidable' carrying
its transient\/permanent cause, so the no-survivors status is a @503@\/@500@ rather than
a @403@). The dropped below-floor versions are projected as 'MissingIntegrity' (no digest
at all) or 'BelowIntegrityFloor' (a digest, but too weak) refusals and appended to those
exclusions, so a packument with /only/ inadmissible public versions is a @403@ rather
than an empty success. Evaluation is IO (an effectful rule may do IO), so this gate is
IO; with only pure rules it short-circuits without launching any IO.

The gated contribution's typed 'PackageInfo' is __restricted to the survivors__:
'mergePackuments' treats a 'GatedSource' as the already-filtered set and never
re-filters, so feeding it the unfiltered view would let a denied version reach the
merge plan (and skew the reconciled @latest@\/@time@). The raw @Value@ needs no
matching restriction: only versions named by the plan's survivors are ever taken
from it at assembly, so a denied version's object is unreachable by construction.

This gate runs on the public path only; the trusted (private) contribution is admitted
separately by 'admitTrusted' against the trusted integrity floor (the rules never run on
it -- the trust split is the caller's). -}
gatePublic :: TracingPort -> MetricsPort -> PackumentDeps -> PackageName -> EvalContext -> Maybe Manifest -> IO (Maybe Contribution, [ServeDecision])
gatePublic :: TracingPort
-> MetricsPort
-> PackumentDeps
-> PackageName
-> EvalContext
-> Maybe Manifest
-> IO (Maybe Contribution, [ServeDecision])
gatePublic TracingPort
tracing MetricsPort
metrics PackumentDeps
deps PackageName
name EvalContext
ctx = \case
    Maybe Manifest
Nothing -> (Maybe Contribution, [ServeDecision])
-> IO (Maybe Contribution, [ServeDecision])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Contribution
forall a. Maybe a
Nothing, [])
    Just Manifest
manifest -> TracingPort -> forall a. PackageName -> IO a -> IO a
spanPackumentGate TracingPort
tracing PackageName
name (IO (Maybe Contribution, [ServeDecision])
 -> IO (Maybe Contribution, [ServeDecision]))
-> IO (Maybe Contribution, [ServeDecision])
-> IO (Maybe Contribution, [ServeDecision])
forall a b. (a -> b) -> a -> b
$ do
        let (PackageInfo
admissible, [ServeDecision]
integrityRefusals) = MinIntegrity
-> ServeDecision
-> ServeDecision
-> PackageInfo
-> (PackageInfo, [ServeDecision])
forall floor.
IntegrityFloor floor =>
floor
-> ServeDecision
-> ServeDecision
-> PackageInfo
-> (PackageInfo, [ServeDecision])
admitByIntegrity (PackumentDeps -> MinIntegrity
pdMinIntegrity PackumentDeps
deps) ServeDecision
integrityBelowFloor ServeDecision
integrityMissing (Manifest -> PackageInfo
manifestInfo Manifest
manifest)
        (decisions, seconds) <- IO (Map Text Decision) -> IO (Map Text Decision, Double)
forall (m :: * -> *) a. MonadIO m => m a -> m (a, Double)
timedSeconds (PackumentDeps
-> EvalContext -> PackageInfo -> IO (Map Text Decision)
decideVersions PackumentDeps
deps EvalContext
ctx PackageInfo
admissible)
        mpRuleEvalDuration metrics (evalTier (pdRules deps)) seconds
        recordEffectfulFailures metrics (Map.elems decisions)
        let plan = Map Text Decision -> PackageInfo -> FilterPlan
filterPlanFromDecisions Map Text Decision
decisions PackageInfo
admissible
        pure $
            if Set.null (fpSurvivors plan)
                then (Nothing, projectDecisions admissible (fpDecisions plan) <> integrityRefusals)
                else
                    ( Just (Contribution GatedSource (restrictToSurvivors (fpSurvivors plan) admissible) (manifestRaw manifest) (manifestDigest manifest))
                    , integrityRefusals
                    )

{- Decide every version of a public packument against the rules engine, keyed by raw
version string (the map 'filterPlanFromDecisions' consumes). Each version is run
through 'Ecluse.Core.Rules.evalRules', so a fail-closed rule that cannot be computed
yields a 'Ecluse.Core.Rules.Types.Undecidable' decision. With only pure rules the
per-version call short-circuits without launching any IO. -}
decideVersions :: PackumentDeps -> EvalContext -> PackageInfo -> IO (Map Text Decision)
decideVersions :: PackumentDeps
-> EvalContext -> PackageInfo -> IO (Map Text Decision)
decideVersions PackumentDeps
deps EvalContext
ctx PackageInfo
info =
    (PackageDetails -> IO Decision)
-> Map Text PackageDetails -> IO (Map Text Decision)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map Text a -> f (Map Text b)
traverse (EvalContext -> [PreparedRule] -> PackageDetails -> IO Decision
evalRules EvalContext
ctx (PackumentDeps -> [PreparedRule]
pdRules PackumentDeps
deps)) (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info)

{- Project each excluded version's 'Decision' to a 'ServeDecision' for the
no-survivors status. The plan carries its decisions ('fpDecisions') in
@versions@-key order ('Data.Map.elems'), so they zip back onto the same-ordered
'PackageDetails' to recover the package\/version each denial is about. -}
projectDecisions :: PackageInfo -> [Decision] -> [ServeDecision]
projectDecisions :: PackageInfo -> [Decision] -> [ServeDecision]
projectDecisions PackageInfo
info =
    (PackageDetails -> Decision -> ServeDecision)
-> [PackageDetails] -> [Decision] -> [ServeDecision]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith PackageDetails -> Decision -> ServeDecision
serveDecisionOf (Map Text PackageDetails -> [PackageDetails]
forall k a. Map k a -> [a]
Map.elems (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info))

-- The fully-edited served body: the raw @Value@ to encode and answer against the
-- conditional request.
newtype ServedBody = ServedBody {ServedBody -> Value
servedValue :: Value}

{- Merge the resolved sources into the serve plan, or 'Nothing' when no version
survives the merge (no source resolved, or every public version was excluded and no
private versions exist). Split from the rendering so the conditional evaluation can
sit between them: the plan (typed, cheap) decides serve-vs-no-survivors, and only a
'Modified' outcome pays for 'renderServedBody'. -}
packumentPlan :: [Contribution] -> Maybe MergePlan
packumentPlan :: [Contribution] -> Maybe MergePlan
packumentPlan [Contribution]
sources = do
    plan <- [(Provenance, PackageInfo)] -> Maybe MergePlan
mergePackuments [(Contribution -> Provenance
srcProvenance Contribution
s, Contribution -> PackageInfo
srcInfo Contribution
s) | Contribution
s <- [Contribution]
sources]
    guard (not (Map.null (mpSurvivors plan)))
    pure plan

{- | The derived packument validator: a SHA-256 over the serve's __inputs__ -- the
mount base URL, the package name, and per source (in merge order) its provenance,
its origin body's digest, and the version keys that survived its gate.

The served document is a deterministic function of exactly these (the merge plan
derives from the gated typed views, which derive from the origin bytes and the
survivor sets; the assembly then edits the origin documents under the mount base
URL), so this tag can never call a changed document unchanged. It may change when
the re-assembled bytes would not have -- a spurious @200@, never a wrong @304@ --
which is the correct slack for a validator. Deriving it from inputs is what lets a
@304@ skip assembly, encoding, and any output hashing entirely.

Fields are fed to the hash with unambiguous framing: the digest is fixed-width, the
variable-length pieces are @NUL@-terminated, and each source block closes with an
@\\SOH@ terminator, so no concatenation of adjacent fields can collide with another
split of the same bytes. The leading salt versions the scheme: bump it when the
assembly's behaviour changes so pre-change client caches revalidate as modified.
-}
packumentETag :: Text -> PackageName -> [(Provenance, ContentDigest, [Text])] -> ETag
packumentETag :: Text
-> PackageName -> [(Provenance, ContentDigest, [Text])] -> ETag
packumentETag Text
mountBaseUrl PackageName
name [(Provenance, ContentDigest, [Text])]
sources =
    Digest SHA256 -> ETag
mkStrongETag (Context SHA256 -> Digest SHA256
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize (Context SHA256 -> [ByteString] -> Context SHA256
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates (Context SHA256
forall a. HashAlgorithm a => Context a
hashInit :: Context SHA256) [ByteString]
pieces))
  where
    pieces :: [ByteString]
    pieces :: [ByteString]
pieces =
        [ ByteString
"ecluse:packument-etag:v1\0"
        , Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
mountBaseUrl ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\0"
        , Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (PackageName -> Text
renderPackageName PackageName
name) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\0"
        ]
            [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> ((Provenance, ContentDigest, [Text]) -> [ByteString])
-> [(Provenance, ContentDigest, [Text])] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Provenance, ContentDigest, [Text]) -> [ByteString]
sourcePieces [(Provenance, ContentDigest, [Text])]
sources

    sourcePieces :: (Provenance, ContentDigest, [Text]) -> [ByteString]
    sourcePieces :: (Provenance, ContentDigest, [Text]) -> [ByteString]
sourcePieces (Provenance
provenance, ContentDigest
digest, [Text]
survivors) =
        Provenance -> ByteString
provenanceTag Provenance
provenance
            ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ContentDigest -> ByteString
digestBytes ContentDigest
digest
            ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
v -> Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
v ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\0") [Text]
survivors
                [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString
"\1"]

    provenanceTag :: Provenance -> ByteString
    provenanceTag :: Provenance -> ByteString
provenanceTag = \case
        Provenance
TrustedSource -> ByteString
"t\0"
        Provenance
GatedSource -> ByteString
"g\0"

-- The validator is a content address over every serve input, so the assembled,
-- encoded document is memoised under it: a recurring triple (public entry,
-- private content, plan) serves the stored bytes with no assembly or encode, and
-- concurrent identical renders coalesce onto one leader. A changed input is a
-- changed key, so the store cannot serve stale bytes; a different private view is
-- a different key, so it cannot cross a client boundary.
servedBytes :: ServeRuntime -> PackumentDeps -> [Contribution] -> MergePlan -> ETag -> IO ByteString
servedBytes :: ServeRuntime
-> PackumentDeps
-> [Contribution]
-> MergePlan
-> ETag
-> IO ByteString
servedBytes ServeRuntime
rt PackumentDeps
deps [Contribution]
sources MergePlan
plan ETag
etag =
    MetricsPort
-> MetadataCache -> Text -> IO ByteString -> IO ByteString
resolveAssembled (ServeRuntime -> MetricsPort
srMetrics ServeRuntime
rt) (ServeRuntime -> MetadataCache
srMetadataCache ServeRuntime
rt) (ETag -> Text
renderETag ETag
etag) (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
        ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$!
            LByteString -> ByteString
LBS.toStrict (Value -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode (ServedBody -> Value
servedValue (PackumentDeps -> [Contribution] -> MergePlan -> ServedBody
renderServedBody PackumentDeps
deps [Contribution]
sources MergePlan
plan)))

{- Assemble the served packument by replaying the 'MergePlan' onto the sources' raw
@Value@s.

The merge decides over the typed 'PackageInfo's; the served body is built from the
raw @Value@s so unmodeled keys survive. For each surviving @(version, SourceId)@
the version object is taken from that source's raw @Value@; @dist-tags@ and @time@
come from the plan (with @time@'s non-version bookkeeping keys retained from the
sources); every other top-level key is relayed from the precedence-winning
document. Tarball URLs are rewritten under the mount base so artifacts route back
through the gate. Runs only on a 'Modified' outcome -- a @304@ never pays for it. -}
renderServedBody :: PackumentDeps -> [Contribution] -> MergePlan -> ServedBody
renderServedBody :: PackumentDeps -> [Contribution] -> MergePlan -> ServedBody
renderServedBody PackumentDeps
deps [Contribution]
sources MergePlan
plan =
    Value -> ServedBody
ServedBody (PackumentDeps
-> Text -> Map Int Value -> MergePlan -> Value -> Value
pdAssemble PackumentDeps
deps (PackumentDeps -> Text
pdMountBaseUrl PackumentDeps
deps) Map Int Value
bySource MergePlan
plan ([Contribution] -> Value
baseDocument [Contribution]
sources))
  where
    bySource :: Map SourceId Value
    bySource :: Map Int Value
bySource = [(Int, Value)] -> Map Int Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Int] -> [Value] -> [(Int, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] ((Contribution -> Value) -> [Contribution] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Contribution -> Value
srcValue [Contribution]
sources))

{- The document whose unmodeled top-level keys are relayed into the served body:
the precedence-winning source's raw @Value@ -- the first trusted source if any,
else the first source. (The merge takes its identity from the first input
likewise.) An empty source list never reaches here. -}
baseDocument :: [Contribution] -> Value
baseDocument :: [Contribution] -> Value
baseDocument [Contribution]
sources =
    case (Contribution -> Bool) -> [Contribution] -> Maybe Contribution
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Provenance -> Provenance -> Bool
forall a. Eq a => a -> a -> Bool
== Provenance
TrustedSource) (Provenance -> Bool)
-> (Contribution -> Provenance) -> Contribution -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contribution -> Provenance
srcProvenance) [Contribution]
sources of
        Just Contribution
s -> Contribution -> Value
srcValue Contribution
s
        Maybe Contribution
Nothing -> case [Contribution]
sources of
            Contribution
s : [Contribution]
_ -> Contribution -> Value
srcValue Contribution
s
            [] -> Object -> Value
Object Object
forall a. Monoid a => a
mempty

{- The per-version serve decisions weighed for the no-survivors status: the
public-set exclusions, plus the per-origin signals each upstream contributes.

A private upstream that did not resolve is a needed-but-unavailable transient signal
(it may resolve on retry), so a private outage with no public survivors is a @503@
rather than a @403@. An origin (private or public) that __answered with a packument
for a different package__ contributes an 'UpstreamInvalid' signal, so a request whose
only responding origins were invalid this way renders a @502@ -- distinct from a
genuine absence. A public upstream that merely did not resolve degrades silently, as
before: its absence is not by itself a needed-upstream outage. -}
collectDecisions :: OriginResult -> OriginResult -> [ServeDecision] -> [ServeDecision]
collectDecisions :: OriginResult -> OriginResult -> [ServeDecision] -> [ServeDecision]
collectDecisions OriginResult
privResult OriginResult
pubResult [ServeDecision]
publicExclusions =
    OriginResult -> [ServeDecision]
privateDecision OriginResult
privResult [ServeDecision] -> [ServeDecision] -> [ServeDecision]
forall a. Semigroup a => a -> a -> a
<> OriginResult -> [ServeDecision]
publicMismatch OriginResult
pubResult [ServeDecision] -> [ServeDecision] -> [ServeDecision]
forall a. Semigroup a => a -> a -> a
<> [ServeDecision]
publicExclusions
  where
    privateDecision :: OriginResult -> [ServeDecision]
    privateDecision :: OriginResult -> [ServeDecision]
privateDecision = \case
        OriginResolved Manifest
_ -> []
        OriginResult
OriginUnresolved -> [ServeDecision
neededUpstreamUnavailable]
        OriginResult
OriginNameMismatch -> [ServeDecision
upstreamInvalidDecision]

    publicMismatch :: OriginResult -> [ServeDecision]
    publicMismatch :: OriginResult -> [ServeDecision]
publicMismatch = \case
        OriginResult
OriginNameMismatch -> [ServeDecision
upstreamInvalidDecision]
        OriginResolved Manifest
_ -> []
        OriginResult
OriginUnresolved -> []

    neededUpstreamUnavailable :: ServeDecision
    neededUpstreamUnavailable :: ServeDecision
neededUpstreamUnavailable = Rejection -> ServeDecision
Reject (RejectReason -> Text -> Rejection
Rejection (Transience -> RejectReason
Unavailable (Maybe RetryAfter -> Transience
WillResolve Maybe RetryAfter
forall a. Maybe a
Nothing)) Text
"a needed upstream was unavailable")

    upstreamInvalidDecision :: ServeDecision
    upstreamInvalidDecision :: ServeDecision
upstreamInvalidDecision = Rejection -> ServeDecision
Reject (RejectReason -> Text -> Rejection
Rejection RejectReason
UpstreamInvalid Text
"an upstream returned a packument for a different package")

{- The served packument @200@ over the (possibly memoised) assembled bytes, carrying
the derived 'ETag' the caller already evaluated the conditional against ('Modified' --
a match never reaches here). The bytes come from 'resolveAssembled': strict, encoded
once per content address, shared across every request whose inputs coincide. A
'PackumentHead' additionally advertises the body's exact @Content-Length@ (the
'bodiless' wrapper then withholds the bytes), free off the memoised bytes. -}
packumentResponse :: PackumentServe -> ETag -> ByteString -> Response
packumentResponse :: PackumentServe -> ETag -> ByteString -> Response
packumentResponse PackumentServe
mode ETag
etag ByteString
bytes = case PackumentServe
mode of
    PackumentServe
PackumentFull ->
        Status -> RequestHeaders -> LByteString -> Response
jsonResponse Status
status200 [ETag -> Header
etagHeader ETag
etag] (ByteString -> LByteString
LBS.fromStrict ByteString
bytes)
    PackumentServe
PackumentHead ->
        Status -> RequestHeaders -> LByteString -> Response
jsonResponse
            Status
status200
            [ETag -> Header
etagHeader ETag
etag, (HeaderName
hContentLength, Int -> ByteString
forall b a. (Show a, IsString b) => a -> b
show (ByteString -> Int
BS.length ByteString
bytes))]
            (ByteString -> LByteString
LBS.fromStrict ByteString
bytes)

-- The bodiless conditional answer: the client's validator matched, so only the tag
-- travels. Identical between GET and HEAD (a 304 carries no body either way).
notModifiedResponse :: ETag -> Response
notModifiedResponse :: ETag -> Response
notModifiedResponse ETag
etag =
    Status -> RequestHeaders -> LByteString -> Response
jsonResponse (Int -> ByteString -> Status
mkStatus Int
304 ByteString
"Not Modified") [ETag -> Header
etagHeader ETag
etag] LByteString
""

{- Render the no-survivors outcome: the status 'packumentStatus' chose over the
exclusions, with a denial body collecting the reasons. Never a @404@ -- the package
existed and its versions were withheld. -}
noSurvivors :: MountRenderer -> PackumentDeps -> [ServeDecision] -> Response
noSurvivors :: MountRenderer -> PackumentDeps -> [ServeDecision] -> Response
noSurvivors MountRenderer
renderer PackumentDeps
deps [ServeDecision]
decisions =
    Status -> RequestHeaders -> RenderedBody -> Response
renderedResponse (PackumentStatus -> Status
toStatus PackumentStatus
status) (PackumentStatus -> RequestHeaders
retryAfterHeader PackumentStatus
status) (MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer (PackumentDeps -> Maybe HelpMessage
pdHelp PackumentDeps
deps) Text
message)
  where
    status :: PackumentStatus
    status :: PackumentStatus
status = [ServeDecision] -> PackumentStatus
packumentStatus [ServeDecision]
decisions

    toStatus :: PackumentStatus -> Status
    toStatus :: PackumentStatus -> Status
toStatus PackumentStatus
s = Int -> ByteString -> Status
mkStatus (PackumentStatus -> Int
packumentStatusCode PackumentStatus
s) (PackumentStatus -> ByteString
statusReason PackumentStatus
s)

    statusReason :: PackumentStatus -> ByteString
    statusReason :: PackumentStatus -> ByteString
statusReason = \case
        PackumentStatus
PackumentOk -> ByteString
"OK"
        PackumentStatus
PackumentForbidden -> ByteString
"Forbidden"
        PackumentUnavailable{} -> ByteString
"Service Unavailable"
        PackumentStatus
PackumentBadGateway -> ByteString
"Bad Gateway"
        PackumentStatus
PackumentServerError -> ByteString
"Internal Server Error"

    -- The collected denial reasons; an empty set (no versions at all) renders a
    -- deny-by-default message rather than an empty body.
    message :: Text
    message :: Text
message = case (ServeDecision -> Maybe Text) -> [ServeDecision] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ServeDecision -> Maybe Text
rejectionText [ServeDecision]
decisions of
        [] -> Text
"no versions are available for this package"
        [Text]
reasons -> Text -> [Text] -> Text
T.intercalate Text
"; " [Text]
reasons

    rejectionText :: ServeDecision -> Maybe Text
    rejectionText :: ServeDecision -> Maybe Text
rejectionText = \case
        ServeDecision
Admit -> Maybe Text
forall a. Maybe a
Nothing
        Reject Rejection
rej -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Rejection -> Text
rejectionMessage Rejection
rej)

-- The @Retry-After@ header for a transient no-survivors status, when a delay was
-- suggested; nothing for the other statuses.
retryAfterHeader :: PackumentStatus -> ResponseHeaders
retryAfterHeader :: PackumentStatus -> RequestHeaders
retryAfterHeader = \case
    PackumentUnavailable (Just (RetryAfter Int
secs)) -> [(HeaderName
"Retry-After", Int -> ByteString
forall b a. (Show a, IsString b) => a -> b
show Int
secs)]
    PackumentStatus
_ -> []