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

{- | The gated leg of the artifact path: vet the requested version, then relay the public upstream.

The gate runs the same admission oracle the worker's ingest re-evaluation runs, so a version the
worker would refuse is refused here too. An admitted @GET@ enqueues the demand-driven mirror.
-}
module Ecluse.Core.Server.Pipeline.Tarball.Public (
    servePublicArtifact,

    -- * The public artifact gate (exposed for direct testing)
    PublicArtifactGate (..),
    publicArtifactGate,
) where

import Network.Wai (ResponseReceived)

import Ecluse.Core.Cve.Types (DbEtag)
import Ecluse.Core.Fault (TransportFault, tfDetail)
import Ecluse.Core.Package (Artifact (artUrl), PackageDetails)
import Ecluse.Core.Package.Admission (
    ArtifactAdmission (
        AdmissionAdmit,
        AdmissionBelowFloor,
        AdmissionDenied,
        AdmissionFileAbsent,
        AdmissionIntegrityMissing,
        AdmissionUndecidable
    ),
    admissionTransience,
    admitArtifactWithEvidence,
 )
import Ecluse.Core.Queue (
    MirrorJob (MirrorJob, jobArtifactFilename, jobArtifactUrl, jobPackage, jobTraceContext, jobVersion),
    RemoteSpanContext,
    enqueue,
 )
import Ecluse.Core.Registry.Adapter.Capability (AdapterArtifact (artifactByUrl))
import Ecluse.Core.Registry.Metadata (
    MetadataError,
    VersionDoc (vdDetails),
    VersionEvaluation (VersionMetadataUnavailable, VersionMissing, VersionPresent),
    VersionRead,
    versionEvaluation,
 )
import Ecluse.Core.Rules (renderDecision)
import Ecluse.Core.Rules.Types (EvalContext, SkippedCheck, completeEvidence, mkEvalContext)
import Ecluse.Core.Security (Limits (progressFloor), Origin (UntrustedOrigin), hostPortAddress, thgPublicHostPort)
import Ecluse.Core.Security.Egress (RegistryUrl)
import Ecluse.Core.Server.Cache.Store (PreparedStore, executePrepared)
import Ecluse.Core.Server.Context (
    Handler,
    PackumentDeps (..),
    ServeRuntime (..),
    pdMirror,
    pdTarballHostGate,
    tarballHostHonoured,
 )
import Ecluse.Core.Server.Path (Filename)
import Ecluse.Core.Server.Pipeline.Internal (
    VersionVerdict (..),
    evalTier,
    logDenials,
    logSkippedChecksOnce,
    recordDenials,
    serveDecisionClass,
 )
import Ecluse.Core.Server.Pipeline.Origin (preparePublicMetadata)
import Ecluse.Core.Server.Pipeline.Shared
import Ecluse.Core.Server.Pipeline.Tarball.Refusal (
    artifactError,
    crossHostRefused,
    internalArtifactError,
    upstreamUnavailable,
    versionAbsent,
 )
import Ecluse.Core.Server.Pipeline.Tarball.Relay (
    ArtifactServe (ServeFull, ServeHead),
    RelayVerdict (RelayedArtifact, RelayedNonSuccess, RelayedOddShape),
    observeRelayAnomaly,
    relayJudged,
    relayUpstreamWhen,
    withMethod,
    withValidators,
 )
import Ecluse.Core.Server.Pipeline.Tarball.Types (ArtifactRequest (..), TarballReplies (..))
import Ecluse.Core.Server.Response (
    ServeDecision (Admit),
    Transience (WontResolve),
    mkRefusal,
    rejectUnavailable,
    serveDecisionOf,
 )
import Ecluse.Core.Server.Stream (RelayResponder (RelayResponder))
import Ecluse.Core.Server.Upstream (MirrorServePlan (MirrorOnAdmit, NoMirrorWrite))
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 (renderVersion)
import UnliftIO (withRunInIO)

-- | Gate the requested version under the mount's admission budget, then relay it.
servePublicArtifact :: ArtifactRequest response -> Handler ResponseReceived
servePublicArtifact :: forall response.
ArtifactRequest response -> Handler ResponseReceived
servePublicArtifact ArtifactRequest response
ctx = do
    -- The advisory database active for this request, resolved once and used both for the
    -- version's evaluation and for a denial's audit line.
    advisoryEtag <- IO (Maybe DbEtag) -> Handler (Maybe DbEtag)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (PackumentDeps -> IO (Maybe DbEtag)
pdAdvisoryEtag (ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx))
    -- A selected read keeps one release, so its entry step is its whole charge.
    withMetadataAdmission
        (arRuntime ctx)
        (liftIO (arRespond ctx (tarballError (arReplies ctx) shedStatus [shedRetryAfter] (mkRefusal Nothing shedMessage))))
        (const (preparePublicMetadata (arRuntime ctx) (arDeps ctx) (arPackage ctx) (arVersion ctx) >>= gatePublicVersion ctx advisoryEtag))
        $ \case
            Admitted Artifact
artifact [SkippedCheck]
skipped -> ArtifactRequest response
-> Maybe DbEtag
-> Artifact
-> [SkippedCheck]
-> Handler ResponseReceived
forall response.
ArtifactRequest response
-> Maybe DbEtag
-> Artifact
-> [SkippedCheck]
-> Handler ResponseReceived
serveAdmitted ArtifactRequest response
ctx Maybe DbEtag
advisoryEtag Artifact
artifact [SkippedCheck]
skipped
            Refused ServeDecision
decision -> ArtifactRequest response
-> Maybe DbEtag -> ServeDecision -> Handler ResponseReceived
forall response.
ArtifactRequest response
-> Maybe DbEtag -> ServeDecision -> Handler ResponseReceived
refusePublic ArtifactRequest response
ctx Maybe DbEtag
advisoryEtag ServeDecision
decision

-- Stream an admitted artifact, recording the admission and the checks the gate had to skip.
serveAdmitted :: ArtifactRequest response -> Maybe DbEtag -> Artifact -> [SkippedCheck] -> Handler ResponseReceived
serveAdmitted :: forall response.
ArtifactRequest response
-> Maybe DbEtag
-> Artifact
-> [SkippedCheck]
-> Handler ResponseReceived
serveAdmitted ArtifactRequest response
ctx Maybe DbEtag
advisoryEtag Artifact
artifact [SkippedCheck]
skipped = do
    let metrics :: MetricsPort
metrics = ServeRuntime -> MetricsPort
srMetrics (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx)
    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)
    (AdmissionIdentity -> IO Bool)
-> PackageName
-> Text
-> Maybe DbEtag
-> [SkippedCheck]
-> Handler ()
forall (m :: * -> *).
KatipContext m =>
(AdmissionIdentity -> IO Bool)
-> PackageName -> Text -> Maybe DbEtag -> [SkippedCheck] -> m ()
logSkippedChecksOnce (PackumentDeps -> AdmissionIdentity -> IO Bool
pdNoteAdmission (ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx)) (ArtifactRequest response -> PackageName
forall response. ArtifactRequest response -> PackageName
arPackage ArtifactRequest response
ctx) (Version -> Text
renderVersion (ArtifactRequest response -> Version
forall response. ArtifactRequest response -> Version
arVersion ArtifactRequest response
ctx)) Maybe DbEtag
advisoryEtag [SkippedCheck]
skipped
    ((forall a. Handler a -> IO a) -> IO ResponseReceived)
-> Handler ResponseReceived
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 ResponseReceived)
 -> Handler ResponseReceived)
-> ((forall a. Handler a -> IO a) -> IO ResponseReceived)
-> Handler ResponseReceived
forall a b. (a -> b) -> a -> b
$ \forall a. Handler a -> IO a
runInIO ->
        ArtifactRequest response
-> Artifact -> (RelayVerdict -> IO ()) -> IO ResponseReceived
forall response.
ArtifactRequest response
-> Artifact -> (RelayVerdict -> IO ()) -> IO ResponseReceived
streamPublicArtifact ArtifactRequest response
ctx Artifact
artifact (Handler () -> IO ()
forall a. Handler a -> IO a
runInIO (Handler () -> IO ())
-> (RelayVerdict -> Handler ()) -> RelayVerdict -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetricsPort -> PackageName -> Version -> RelayVerdict -> Handler ()
forall (m :: * -> *).
KatipContext m =>
MetricsPort -> PackageName -> Version -> RelayVerdict -> m ()
observeRelayAnomaly MetricsPort
metrics (ArtifactRequest response -> PackageName
forall response. ArtifactRequest response -> PackageName
arPackage ArtifactRequest response
ctx) (ArtifactRequest response -> Version
forall response. ArtifactRequest response -> Version
arVersion ArtifactRequest response
ctx))

-- Answer a gate refusal, recording the denial on the metrics and the audit log.
refusePublic :: ArtifactRequest response -> Maybe DbEtag -> ServeDecision -> Handler ResponseReceived
refusePublic :: forall response.
ArtifactRequest response
-> Maybe DbEtag -> ServeDecision -> Handler ResponseReceived
refusePublic ArtifactRequest response
ctx Maybe DbEtag
advisoryEtag ServeDecision
decision = do
    let metrics :: MetricsPort
metrics = ServeRuntime -> MetricsPort
srMetrics (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx)
    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
serveDecisionClass ServeDecision
decision))
    PackageName -> Maybe DbEtag -> [VersionVerdict] -> Handler ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> Maybe DbEtag -> [VersionVerdict] -> m ()
logDenials (ArtifactRequest response -> PackageName
forall response. ArtifactRequest response -> PackageName
arPackage ArtifactRequest response
ctx) Maybe DbEtag
advisoryEtag [Text -> ServeDecision -> VersionVerdict
VersionVerdict (Version -> Text
renderVersion (ArtifactRequest response -> Version
forall response. ArtifactRequest response -> Version
arVersion ArtifactRequest response
ctx)) ServeDecision
decision]
    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
decision])
    IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ArtifactRequest response -> response -> IO ResponseReceived
forall response.
ArtifactRequest response -> response -> IO ResponseReceived
arRespond ArtifactRequest response
ctx (TarballReplies response
-> PackumentDeps -> ServeDecision -> response
forall response.
TarballReplies response
-> PackumentDeps -> ServeDecision -> response
artifactError (ArtifactRequest response -> TarballReplies response
forall response.
ArtifactRequest response -> TarballReplies response
arReplies ArtifactRequest response
ctx) (ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx) ServeDecision
decision))

-- | Preserve the admitted artifact's authoritative location through the public gate.
data PublicArtifactGate
    = -- | The gate admitted the version: the artifact selected by filename, and the checks the admission skipped.
      Admitted Artifact [SkippedCheck]
    | -- | The gate refused the version: a policy denial, an upstream outage, or absence.
      Refused ServeDecision

-- Execute the captured read and fresh policy while both admission brackets are held.
gatePublicVersion :: ArtifactRequest response -> Maybe DbEtag -> PreparedStore MetadataError VersionRead -> Handler PublicArtifactGate
gatePublicVersion :: forall response.
ArtifactRequest response
-> Maybe DbEtag
-> PreparedStore MetadataError VersionRead
-> Handler PublicArtifactGate
gatePublicVersion ArtifactRequest response
ctx Maybe DbEtag
advisoryEtag PreparedStore MetadataError VersionRead
prepared = do
    evalCtx <- IO EvalContext -> Handler EvalContext
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> IO (Maybe DbEtag) -> IO EvalContext
mkEvalContext (PackumentDeps -> IO UTCTime
pdNow PackumentDeps
deps) (Maybe DbEtag -> IO (Maybe DbEtag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DbEtag
advisoryEtag))
    eval <- liftIO (versionEvaluation <$> executePrepared prepared)
    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 VersionDoc
doc Maybe Version
_ ->
            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) (ArtifactRequest response -> PackageName
forall response. ArtifactRequest response -> PackageName
arPackage ArtifactRequest response
ctx) (ArtifactRequest response -> Version
forall response. ArtifactRequest response -> Version
arVersion ArtifactRequest response
ctx) (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
-> Filename
-> PackageDetails
-> IO PublicArtifactGate
gateVersion EvalContext
evalCtx PackumentDeps
deps (ArtifactRequest response -> Filename
forall response. ArtifactRequest response -> Filename
arFile ArtifactRequest response
ctx) (VersionDoc -> PackageDetails
vdDetails VersionDoc
doc))
                    mpRuleEvalDuration (srMetrics rt) (evalTier (pdRules deps)) seconds
                    pure (gate, gateVerdict gate)
  where
    rt :: ServeRuntime
rt = ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx
    deps :: PackumentDeps
deps = ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx

-- The serve verdict a gate outcome carries, for the rule-eval span.
gateVerdict :: PublicArtifactGate -> ServeDecision
gateVerdict :: PublicArtifactGate -> ServeDecision
gateVerdict = \case
    Admitted{} -> ServeDecision
Admit
    Refused ServeDecision
decision -> ServeDecision
decision

{- Gate one requested artifact through the shared admission oracle the worker's ingest
re-evaluation also runs. The trusted private leg never reaches this gate. -}
gateVersion :: EvalContext -> PackumentDeps -> Filename -> PackageDetails -> IO PublicArtifactGate
gateVersion :: EvalContext
-> PackumentDeps
-> Filename
-> PackageDetails
-> IO PublicArtifactGate
gateVersion EvalContext
ctx PackumentDeps
deps Filename
file PackageDetails
details =
    (ArtifactAdmission -> [SkippedCheck] -> PublicArtifactGate)
-> (ArtifactAdmission, [SkippedCheck]) -> PublicArtifactGate
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (PackageDetails
-> ArtifactAdmission -> [SkippedCheck] -> PublicArtifactGate
publicArtifactGate PackageDetails
details) ((ArtifactAdmission, [SkippedCheck]) -> PublicArtifactGate)
-> IO (ArtifactAdmission, [SkippedCheck]) -> IO PublicArtifactGate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalContext
-> [PreparedRule]
-> MinIntegrity
-> Filename
-> PackageDetails
-> IO (ArtifactAdmission, [SkippedCheck])
admitArtifactWithEvidence EvalContext
ctx (PackumentDeps -> [PreparedRule]
pdRules PackumentDeps
deps) (PackumentDeps -> MinIntegrity
pdMinIntegrity PackumentDeps
deps) Filename
file PackageDetails
details

-- | Render the shared admission verdict on the serve surface.
publicArtifactGate :: PackageDetails -> ArtifactAdmission -> [SkippedCheck] -> PublicArtifactGate
publicArtifactGate :: PackageDetails
-> ArtifactAdmission -> [SkippedCheck] -> PublicArtifactGate
publicArtifactGate PackageDetails
details ArtifactAdmission
admission [SkippedCheck]
skipped = case ArtifactAdmission
admission of
    -- The carried floor-checked digest set is the worker's ingest concern. The serve path
    -- streams without rehashing, so it has no consumer for the set.
    AdmissionAdmit Filename
_ Artifact
artifact NonEmpty Hash
_ -> Artifact -> [SkippedCheck] -> PublicArtifactGate
Admitted Artifact
artifact [SkippedCheck]
skipped
    AdmissionDenied Decision
decision -> ServeDecision -> PublicArtifactGate
Refused (PackageDetails -> Decision -> ServeDecision
serveDecisionOf PackageDetails
details Decision
decision)
    AdmissionUndecidable Decision
decision -> ServeDecision -> PublicArtifactGate
Refused (Transience -> Text -> ServeDecision
rejectUnavailable Transience
transience (RuleEvidence -> Decision -> Text
renderDecision (PackageDetails -> RuleEvidence
completeEvidence PackageDetails
details) Decision
decision))
    ArtifactAdmission
AdmissionFileAbsent -> ServeDecision -> PublicArtifactGate
Refused ServeDecision
versionAbsent
    ArtifactAdmission
AdmissionBelowFloor -> ServeDecision -> PublicArtifactGate
Refused ServeDecision
integrityBelowFloor
    ArtifactAdmission
AdmissionIntegrityMissing -> ServeDecision -> PublicArtifactGate
Refused ServeDecision
integrityMissing
  where
    -- The @503@-versus-@500@ transience is the shared projection's, the one the worker's
    -- retry-versus-drop reads. A settled verdict cannot be waited out.
    transience :: Transience
transience = Transience -> Maybe Transience -> Transience
forall a. a -> Maybe a -> a
fromMaybe Transience
WontResolve (ArtifactAdmission -> Maybe Transience
admissionTransience ArtifactAdmission
admission)

streamPublicArtifact ::
    ArtifactRequest response ->
    Artifact ->
    -- | Observe the relay verdict (the anomaly log line and metric).
    (RelayVerdict -> IO ()) ->
    IO ResponseReceived
streamPublicArtifact :: forall response.
ArtifactRequest response
-> Artifact -> (RelayVerdict -> IO ()) -> IO ResponseReceived
streamPublicArtifact ArtifactRequest response
ctx Artifact
artifact RelayVerdict -> IO ()
observeVerdict
    | Bool -> Bool
not Bool
hostHonoured = response -> IO ResponseReceived
respond (TarballReplies response -> response
forall response. TarballReplies response -> response
crossHostRefused TarballReplies response
replies)
    | Bool
otherwise = case Either UrlFormationError Request
publicRequest of
        Left UrlFormationError
_ -> response -> IO ResponseReceived
respond (TarballReplies response -> response
forall response. TarballReplies response -> response
internalArtifactError TarballReplies response
replies)
        Right Request
req ->
            ArtifactServe
-> Manager
-> ProgressFloor
-> Request
-> (Status -> Bool)
-> (Status
    -> ResponseHeaders -> IO (Status, ResponseHeaders, RelayVerdict))
-> RelayResponder ResponseReceived
-> IO (Maybe (RelayVerdict, ResponseReceived))
forall verdict response.
ArtifactServe
-> Manager
-> ProgressFloor
-> Request
-> (Status -> Bool)
-> (Status
    -> ResponseHeaders -> IO (Status, ResponseHeaders, verdict))
-> RelayResponder response
-> IO (Maybe (verdict, response))
relayUpstreamWhen (ArtifactRequest response -> ArtifactServe
forall response. ArtifactRequest response -> ArtifactServe
arMode ArtifactRequest response
ctx) (ServeRuntime -> Manager
srPublicManager (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx)) (Limits -> ProgressFloor
progressFloor (PackumentDeps -> Limits
pdLimits (ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx))) Request
req (Bool -> Status -> Bool
forall a b. a -> b -> a
const Bool
True) Status
-> ResponseHeaders -> IO (Status, ResponseHeaders, RelayVerdict)
relayJudged (TarballReplies response
-> (response -> IO ResponseReceived)
-> RelayResponder ResponseReceived
forall response received.
TarballReplies response
-> (response -> IO received) -> RelayResponder received
relayResponder TarballReplies response
replies response -> IO ResponseReceived
respond) IO (Maybe (RelayVerdict, ResponseReceived))
-> (Maybe (RelayVerdict, 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 (RelayVerdict
verdict, ResponseReceived
received) -> do
                    RelayVerdict -> IO ()
observeVerdict RelayVerdict
verdict
                    ArtifactRequest response -> Artifact -> RelayVerdict -> IO ()
forall response.
ArtifactRequest response -> Artifact -> RelayVerdict -> IO ()
mirrorOnAdmit ArtifactRequest response
ctx Artifact
artifact RelayVerdict
verdict
                    ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
received
                Maybe (RelayVerdict, ResponseReceived)
Nothing -> response -> IO ResponseReceived
respond (TarballReplies response
-> PackumentDeps -> ServeDecision -> response
forall response.
TarballReplies response
-> PackumentDeps -> ServeDecision -> response
artifactError TarballReplies response
replies PackumentDeps
deps ServeDecision
upstreamUnavailable)
  where
    deps :: PackumentDeps
deps = ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx
    replies :: TarballReplies response
replies = ArtifactRequest response -> TarballReplies response
forall response.
ArtifactRequest response -> TarballReplies response
arReplies ArtifactRequest response
ctx
    respond :: response -> IO ResponseReceived
respond = ArtifactRequest response -> response -> IO ResponseReceived
forall response.
ArtifactRequest response -> response -> IO ResponseReceived
arRespond ArtifactRequest response
ctx

    hostHonoured :: Bool
hostHonoured = Origin -> PackumentDeps -> Maybe HostPort -> Maybe HostPort -> Bool
tarballHostHonoured Origin
UntrustedOrigin PackumentDeps
deps (TarballHostGate -> Maybe HostPort
thgPublicHostPort (PackumentDeps -> TarballHostGate
pdTarballHostGate PackumentDeps
deps)) (Text -> Maybe HostPort
hostPortAddress (Artifact -> Text
artUrl Artifact
artifact))

    publicRequest :: Either UrlFormationError Request
publicRequest = ResponseHeaders -> Request -> Request
withValidators (ArtifactRequest response -> ResponseHeaders
forall response. ArtifactRequest response -> ResponseHeaders
arValidators ArtifactRequest response
ctx) (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArtifactServe -> Request -> Request
withMethod (ArtifactRequest response -> ArtifactServe
forall response. ArtifactRequest response -> ArtifactServe
arMode ArtifactRequest response
ctx) (Request -> Request)
-> Either UrlFormationError Request
-> Either UrlFormationError Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AdapterArtifact
-> Maybe ClientCredential
-> Text
-> Either UrlFormationError Request
artifactByUrl (PackumentDeps -> AdapterArtifact
pdArtifact PackumentDeps
deps) Maybe ClientCredential
forall a. Maybe a
Nothing (Artifact -> Text
artUrl Artifact
artifact)

{- Back-fill the mirror only for a relayed artifact on the @GET@ path. A @HEAD@ served no bytes,
and an odd-shaped or non-success relay is not the artifact. -}
mirrorOnAdmit :: ArtifactRequest response -> Artifact -> RelayVerdict -> IO ()
mirrorOnAdmit :: forall response.
ArtifactRequest response -> Artifact -> RelayVerdict -> IO ()
mirrorOnAdmit ArtifactRequest response
ctx Artifact
artifact RelayVerdict
verdict = case (RelayVerdict
verdict, PackumentDeps -> MirrorServePlan
pdMirror (ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx)) of
    (RelayVerdict
RelayedArtifact, MirrorOnAdmit RegistryUrl
_) -> case ArtifactRequest response -> ArtifactServe
forall response. ArtifactRequest response -> ArtifactServe
arMode ArtifactRequest response
ctx of
        ArtifactServe
ServeFull -> ArtifactRequest response -> Artifact -> IO ()
forall response. ArtifactRequest response -> Artifact -> IO ()
enqueueMirror ArtifactRequest response
ctx Artifact
artifact
        ArtifactServe
ServeHead -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
    (RelayVerdict
RelayedArtifact, MirrorServePlan
NoMirrorWrite) -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
    (RelayedOddShape Text
_, MirrorServePlan
_) -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
    (RelayedNonSuccess Status
_, MirrorServePlan
_) -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass

-- Adapt the route's typed response constructors to the streaming helper's callback. The
-- upstream connection stays open until the selected response completes.
relayResponder :: TarballReplies response -> (response -> IO received) -> RelayResponder received
relayResponder :: forall response received.
TarballReplies response
-> (response -> IO received) -> RelayResponder received
relayResponder TarballReplies response
replies response -> IO received
respond =
    (Status -> ResponseHeaders -> StreamingBody -> IO received)
-> (Status -> ResponseHeaders -> IO received)
-> RelayResponder received
forall response.
(Status -> ResponseHeaders -> StreamingBody -> IO response)
-> (Status -> ResponseHeaders -> IO response)
-> RelayResponder response
RelayResponder
        (\Status
status ResponseHeaders
headers StreamingBody
body -> response -> IO received
respond (TarballReplies response
-> Status -> ResponseHeaders -> StreamingBody -> response
forall response.
TarballReplies response
-> Status -> ResponseHeaders -> StreamingBody -> response
tarballStream TarballReplies response
replies Status
status ResponseHeaders
headers StreamingBody
body))
        (\Status
status ResponseHeaders
headers -> response -> IO received
respond (TarballReplies response -> Status -> ResponseHeaders -> response
forall response.
TarballReplies response -> Status -> ResponseHeaders -> response
tarballEmpty TarballReplies response
replies Status
status ResponseHeaders
headers))

enqueueMirror :: ArtifactRequest response -> Artifact -> IO ()
enqueueMirror :: forall response. ArtifactRequest response -> Artifact -> IO ()
enqueueMirror ArtifactRequest response
ctx Artifact
artifact =
    case PackumentDeps -> Text -> Either Text RegistryUrl
pdEgressUrl (ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx) (Artifact -> Text
artUrl Artifact
artifact) of
        Left Text
_ -> MetricsPort -> IO ()
mpMirrorEnqueueFailure (ServeRuntime -> MetricsPort
srMetrics (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx))
        Right RegistryUrl
egressUrl ->
            IO (Either TransportFault ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either TransportFault ()) -> IO ())
-> ((Maybe RemoteSpanContext -> IO (Either TransportFault ()))
    -> IO (Either TransportFault ()))
-> (Maybe RemoteSpanContext -> IO (Either TransportFault ()))
-> 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 (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx)) (ArtifactRequest response -> PackageName
forall response. ArtifactRequest response -> PackageName
arPackage ArtifactRequest response
ctx) (ArtifactRequest response -> Version
forall response. ArtifactRequest response -> Version
arVersion ArtifactRequest response
ctx) (Artifact -> Text
artUrl Artifact
artifact) Either TransportFault () -> Maybe Text
enqueueErrorDetail ((Maybe RemoteSpanContext -> IO (Either TransportFault ()))
 -> IO ())
-> (Maybe RemoteSpanContext -> IO (Either TransportFault ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$
                ArtifactRequest response
-> RegistryUrl
-> Maybe RemoteSpanContext
-> IO (Either TransportFault ())
forall response.
ArtifactRequest response
-> RegistryUrl
-> Maybe RemoteSpanContext
-> IO (Either TransportFault ())
enqueueJob ArtifactRequest response
ctx RegistryUrl
egressUrl

-- Count the hand-off outcome and hand it back, never propagating it. The composition root's
-- buffer callbacks count drops and backend delivery failures behind the hand-off.
enqueueJob :: ArtifactRequest response -> RegistryUrl -> Maybe RemoteSpanContext -> IO (Either TransportFault ())
enqueueJob :: forall response.
ArtifactRequest response
-> RegistryUrl
-> Maybe RemoteSpanContext
-> IO (Either TransportFault ())
enqueueJob ArtifactRequest response
ctx RegistryUrl
egressUrl Maybe RemoteSpanContext
traceContext = do
    let metrics :: MetricsPort
metrics = ServeRuntime -> MetricsPort
srMetrics (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx)
    enqueued <-
        MirrorQueue -> MirrorJob -> IO (Either TransportFault ())
enqueue
            (ServeRuntime -> MirrorQueue
srQueue (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx))
            MirrorJob
                { jobPackage :: PackageName
jobPackage = ArtifactRequest response -> PackageName
forall response. ArtifactRequest response -> PackageName
arPackage ArtifactRequest response
ctx
                , jobVersion :: Version
jobVersion = ArtifactRequest response -> Version
forall response. ArtifactRequest response -> Version
arVersion ArtifactRequest response
ctx
                , jobArtifactUrl :: RegistryUrl
jobArtifactUrl = RegistryUrl
egressUrl
                , jobArtifactFilename :: Filename
jobArtifactFilename = ArtifactRequest response -> Filename
forall response. ArtifactRequest response -> Filename
arFile ArtifactRequest response
ctx
                , -- 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
                }
    either (const (mpMirrorEnqueueFailure metrics)) (const (mpMirrorEnqueued metrics)) enqueued
    -- The span bracket marks a swallowed failure errored on the producer span.
    pure enqueued

-- Project the swallowed enqueue outcome onto the producer span's status, so a trace explains
-- why the mirror was not enqueued.
enqueueErrorDetail :: Either TransportFault () -> Maybe Text
enqueueErrorDetail :: Either TransportFault () -> Maybe Text
enqueueErrorDetail = (TransportFault -> Maybe Text)
-> (() -> Maybe Text) -> Either TransportFault () -> 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)
-> (TransportFault -> Text) -> TransportFault -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportFault -> Text
enqueueFailureDetail) (Maybe Text -> () -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)

enqueueFailureDetail :: TransportFault -> Text
enqueueFailureDetail :: TransportFault -> Text
enqueueFailureDetail TransportFault
fault = Text
"mirror enqueue failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TransportFault -> Text
tfDetail TransportFault
fault