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

{- | Merge trusted private metadata with admitted public versions and serve conditional responses.
Private access refusals stop the request even when the public origin succeeds.
First-party names consult only the private origin.
-}
module Ecluse.Core.Server.Pipeline.Packument (
    PackumentReplies (..),
    packumentAction,
    servePackument,
    headPackument,

    -- * The first-party private miss (exported for its unit spec)
    firstPartyMissDecision,
    firstPartyMissReply,

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

    -- * The served body and its output charge basis (exported for the residency probe and a unit spec)
    assembleServedBody,
    outputBasisBytes,
) where

import Crypto.Hash (Context, SHA256, hashFinalize, hashInit, hashUpdates)
import Data.ByteString qualified as BS
import Data.ByteString.Builder (Builder, byteString, intDec, toLazyByteString)
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 Katip (Severity (DebugS, InfoS), logFM, ls)
import Network.HTTP.Types (Method, ResponseHeaders, hContentLength)
import Network.Wai (Request, ResponseReceived, requestHeaders)
import UnliftIO (concurrently)
import UnliftIO.Exception (catchAny, throwIO)

import Ecluse.Core.Credential (ClientCredential)
import Ecluse.Core.Cve.Types (DbEtag)
import Ecluse.Core.Package (
    PackageDetails,
    PackageInfo (infoVersions),
    PackageName,
    renderPackageName,
 )
import Ecluse.Core.Package.Entry (EntryKey (..))
import Ecluse.Core.Package.Filter (filterPlanFromDecisions, fpDecisions, fpSurvivors, restrictToSurvivors)
import Ecluse.Core.Package.Integrity (
    MinTrustedIntegrity,
 )
import Ecluse.Core.Package.Merge (
    MergePlan (mpDivergences, mpSurvivors),
    Provenance (GatedSource, TrustedSource),
    SourceId,
    integrityDivergences,
    mergePackuments,
 )
import Ecluse.Core.Registry.Adapter.Capability (AdapterMetadata (metadataAssemble, metadataChargeFactors, metadataSerialise))
import Ecluse.Core.Registry.CachedDocument (CachedDoc)
import Ecluse.Core.Registry.Metadata (
    ContentDigest,
    Manifest (manifestBodyBytes, manifestDigest, manifestInfo, manifestRaw),
    digestBytes,
 )
import Ecluse.Core.Rules (newEvaluator)
import Ecluse.Core.Rules.Types (Decision, EvalContext (ctxAdvisoryEtag), completeEvidence, mkEvalContext)
import Ecluse.Core.Security.Egress (registryUrlText)
import Ecluse.Core.Server.Admission.Budget (scaleCharge)
import Ecluse.Core.Server.Admission.Meter (MemoryTicket, awaitingFlight, charge, servingFlight)
import Ecluse.Core.Server.Admission.Types (ChargeFactors (cfOutputPermille), FlightKey (FlightKey))
import Ecluse.Core.Server.Cache (resolveAssembled)
import Ecluse.Core.Server.Conditional (Conditional (Modified, NotModified), ETag, etagHeader, evaluateETag, mkStrongETag, renderETag)
import Ecluse.Core.Server.Context (
    Handler,
    MountBinding (bindingPackumentDeps),
    PackumentDeps (..),
    ResponseAction (RunPipeline),
    ServeRuntime (..),
    ctxMount,
    ctxRuntime,
    pdPrivateBaseUrl,
    pdPublicBaseUrl,
 )
import Ecluse.Core.Server.Fault (RenderEscape (RenderEscape))
import Ecluse.Core.Server.Pipeline.Diagnostics (warnDivergences)
import Ecluse.Core.Server.Pipeline.Internal (
    VersionVerdict (..),
    admitByIntegrity,
    evalTier,
    logDenials,
    packumentServeDecision,
    recordDenials,
    recordEffectfulFailures,
    statusServeDecision,
 )
import Ecluse.Core.Server.Pipeline.Origin (
    Contribution (..),
    OriginMiss (MissAbsent, MissUnresolved),
    OriginResult (..),
    fetchPrivateOrigin,
    fetchPublicOrigin,
    fingerprintPiece,
    originManifest,
    originMiss,
 )
import Ecluse.Core.Server.Pipeline.Shared
import Ecluse.Core.Server.Response (
    HelpMessage,
    PackumentStatus (PackumentBadGateway, PackumentForbidden, PackumentOk, PackumentServerError, PackumentUnavailable),
    Refusal,
    RejectReason (ByPolicy, Unavailable, UpstreamInvalid),
    Rejection (Rejection, rejectionMessage),
    ServeDecision (Admit, Reject),
    Transience (WillResolve),
    mkRefusal,
    packumentStatus,
    serveDecisionOf,
 )
import Ecluse.Core.Server.Route (isHead)
import Ecluse.Core.Snapshot (Snapshot (..))
import Ecluse.Core.Telemetry.Metrics qualified as Metric
import Ecluse.Core.Telemetry.Record (MetricsPort (..), timedSeconds)
import Ecluse.Core.Telemetry.Span (TracingPort, spanPackumentGate)

-- | The route-owned ways the ecosystem-neutral packument pipeline may answer.
data PackumentReplies response = PackumentReplies
    { forall response.
PackumentReplies response
-> ResponseHeaders -> LByteString -> response
packumentOk :: ResponseHeaders -> LByteString -> response
    , forall response.
PackumentReplies response -> ResponseHeaders -> response
packumentNotModified :: ResponseHeaders -> response
    , forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentUnauthorised :: ResponseHeaders -> Refusal -> response
    , forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentForbidden :: ResponseHeaders -> Refusal -> response
    , forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentNotFound :: ResponseHeaders -> Refusal -> response
    , forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentInternal :: ResponseHeaders -> Refusal -> response
    , forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentBadGateway :: ResponseHeaders -> Refusal -> response
    , forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentUnavailable :: ResponseHeaders -> Refusal -> response
    }

{- | The action a read route names for a package unit. A @HEAD@ takes the head-mode handler,
which runs the identical gating and merge but withholds the body.
-}
packumentAction :: PackumentReplies response -> Method -> PackageName -> ResponseAction response
packumentAction :: forall response.
PackumentReplies response
-> ByteString -> PackageName -> ResponseAction response
packumentAction PackumentReplies response
replies ByteString
method PackageName
name
    | ByteString -> Bool
isHead ByteString
method = response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
forall response.
response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
RunPipeline response
perimeterFallback (PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
headPackument PackumentReplies response
replies PackageName
name)
    | Bool
otherwise = response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
forall response.
response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
RunPipeline response
perimeterFallback (PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
servePackument PackumentReplies response
replies PackageName
name)
  where
    perimeterFallback :: response
perimeterFallback = PackumentReplies response -> ResponseHeaders -> Refusal -> response
forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentInternal PackumentReplies response
replies [] (Maybe HelpMessage -> Text -> Refusal
mkRefusal Maybe HelpMessage
forall a. Maybe a
Nothing Text
"internal server error")

-- | Serve merged metadata while retaining private access authority and package identity checks.
servePackument ::
    PackumentReplies response ->
    PackageName ->
    Request ->
    (response -> IO ResponseReceived) ->
    Handler ResponseReceived
servePackument :: forall response.
PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
servePackument = PackumentServe
-> PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
PackumentServe
-> PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
packumentWith PackumentServe
PackumentFull

-- | Serve the packument's GET status and headers without its body.
headPackument ::
    PackumentReplies response ->
    PackageName ->
    Request ->
    (response -> IO ResponseReceived) ->
    Handler ResponseReceived
headPackument :: forall response.
PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
headPackument = PackumentServe
-> PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
PackumentServe
-> PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
packumentWith PackumentServe
PackumentHead

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

-- Everything a terminal arm of one admitted packument serve answers through. It is assembled once
-- per request so each arm takes it whole instead of eight positional parameters.
data PackumentServing response = PackumentServing
    { forall response. PackumentServing response -> PackumentServe
psvMode :: PackumentServe
    , forall response.
PackumentServing response -> PackumentReplies response
psvReplies :: PackumentReplies response
    , forall response. PackumentServing response -> PackumentDeps
psvDeps :: PackumentDeps
    , forall response. PackumentServing response -> PackageName
psvName :: PackageName
    , forall response. PackumentServing response -> Request
psvRequest :: Request
    , forall response.
PackumentServing response -> response -> IO ResponseReceived
psvRespond :: response -> IO ResponseReceived
    , forall response. PackumentServing response -> ServeRuntime
psvRuntime :: ServeRuntime
    , forall response. PackumentServing response -> MemoryTicket
psvTicket :: MemoryTicket
    -- ^ The request's account with the memory meter, which its reads and its output pay into.
    }

servingMetrics :: PackumentServing response -> MetricsPort
servingMetrics :: forall response. PackumentServing response -> MetricsPort
servingMetrics = ServeRuntime -> MetricsPort
srMetrics (ServeRuntime -> MetricsPort)
-> (PackumentServing response -> ServeRuntime)
-> PackumentServing response
-> MetricsPort
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackumentServing response -> ServeRuntime
forall response. PackumentServing response -> ServeRuntime
psvRuntime

-- The edge token is compared before any upstream is touched, so an unauthenticated client
-- cannot drive egress. Admission is held only for the gated work.
packumentWith ::
    PackumentServe ->
    PackumentReplies response ->
    PackageName ->
    Request ->
    (response -> IO ResponseReceived) ->
    Handler ResponseReceived
packumentWith :: forall response.
PackumentServe
-> PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
packumentWith PackumentServe
mode PackumentReplies response
replies PackageName
name Request
request response -> IO ResponseReceived
respond = do
    ctx <- Handler RequestCtx
forall r (m :: * -> *). MonadReader r m => m r
ask
    let mount = RequestCtx -> MountBinding
ctxMount RequestCtx
ctx
        deps = MountBinding -> PackumentDeps
bindingPackumentDeps MountBinding
mount
        clientToken = MountBinding -> Request -> Maybe ClientCredential
forwardedCredential MountBinding
mount Request
request
        serving MemoryTicket
ticket =
            PackumentServing
                { psvMode :: PackumentServe
psvMode = PackumentServe
mode
                , psvReplies :: PackumentReplies response
psvReplies = PackumentReplies response
replies
                , psvDeps :: PackumentDeps
psvDeps = PackumentDeps
deps
                , psvName :: PackageName
psvName = PackageName
name
                , psvRequest :: Request
psvRequest = Request
request
                , psvRespond :: response -> IO ResponseReceived
psvRespond = response -> IO ResponseReceived
respond
                , psvRuntime :: ServeRuntime
psvRuntime = RequestCtx -> ServeRuntime
ctxRuntime RequestCtx
ctx
                , psvTicket :: MemoryTicket
psvTicket = MemoryTicket
ticket
                }
    if edgeTokenMatches (pdInboundToken deps) clientToken
        then withMetadataAdmission (ctxRuntime ctx) (refuse packumentUnavailable [shedRetryAfter] shedMessage) (\MemoryTicket
ticket -> PackumentServing response
-> Maybe ClientCredential -> Handler ResponseReceived
forall response.
PackumentServing response
-> Maybe ClientCredential -> Handler ResponseReceived
serveAdmittedPackument (MemoryTicket -> PackumentServing response
serving MemoryTicket
ticket) Maybe ClientCredential
clientToken) pure
        else refuse packumentUnauthorised [] unauthorisedMessage
  where
    refuse :: (PackumentReplies response -> t -> Refusal -> response)
-> t -> Text -> m ResponseReceived
refuse PackumentReplies response -> t -> Refusal -> response
reply t
headers Text
message = IO ResponseReceived -> m ResponseReceived
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (response -> IO ResponseReceived
respond (PackumentReplies response -> t -> Refusal -> response
reply PackumentReplies response
replies t
headers (Maybe HelpMessage -> Text -> Refusal
mkRefusal Maybe HelpMessage
forall a. Maybe a
Nothing Text
message)))

serveAdmittedPackument :: PackumentServing response -> Maybe ClientCredential -> Handler ResponseReceived
serveAdmittedPackument :: forall response.
PackumentServing response
-> Maybe ClientCredential -> Handler ResponseReceived
serveAdmittedPackument PackumentServing response
serving Maybe ClientCredential
clientToken = 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 (PackumentServing response -> PackageName
forall response. PackumentServing response -> PackageName
psvName PackumentServing response
serving)))
    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) (PackumentDeps -> IO (Maybe DbEtag)
pdAdvisoryEtag PackumentDeps
deps))
    (privResult, pubResult) <- resolveOrigins deps (psvRuntime serving) (psvTicket serving) clientToken (psvName serving)
    case privResult of
        OriginAuthorisationFailure Int
_ -> PackumentServing response -> Handler ResponseReceived
forall response.
PackumentServing response -> Handler ResponseReceived
privateAccessRefused PackumentServing response
serving
        OriginResult
_ -> PackumentServing response
-> EvalContext
-> OriginResult
-> OriginResult
-> Handler ResponseReceived
forall response.
PackumentServing response
-> EvalContext
-> OriginResult
-> OriginResult
-> Handler ResponseReceived
serveMergedPackument PackumentServing response
serving EvalContext
evalCtx OriginResult
privResult OriginResult
pubResult
  where
    deps :: PackumentDeps
deps = PackumentServing response -> PackumentDeps
forall response. PackumentServing response -> PackumentDeps
psvDeps PackumentServing response
serving

{- Resolve the origins this request may read: a first-party name reads the private origin alone
and never the public leg. Every other name reads both concurrently. -}
resolveOrigins :: PackumentDeps -> ServeRuntime -> MemoryTicket -> Maybe ClientCredential -> PackageName -> Handler (OriginResult, OriginResult)
resolveOrigins :: PackumentDeps
-> ServeRuntime
-> MemoryTicket
-> Maybe ClientCredential
-> PackageName
-> Handler (OriginResult, OriginResult)
resolveOrigins PackumentDeps
deps ServeRuntime
rt MemoryTicket
ticket Maybe ClientCredential
clientToken PackageName
name
    | PackumentDeps -> PackageName -> Bool
pdFirstParty PackumentDeps
deps PackageName
name = do
        privResult <- PackumentDeps
-> ServeRuntime
-> MemoryTicket
-> Maybe ClientCredential
-> PackageName
-> Handler OriginResult
fetchPrivateOrigin PackumentDeps
deps ServeRuntime
rt MemoryTicket
ticket Maybe ClientCredential
clientToken PackageName
name
        pure (privResult, OriginAbsent)
    | Bool
otherwise =
        Handler OriginResult
-> Handler OriginResult -> Handler (OriginResult, OriginResult)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m (a, b)
concurrently
            (PackumentDeps
-> ServeRuntime
-> MemoryTicket
-> Maybe ClientCredential
-> PackageName
-> Handler OriginResult
fetchPrivateOrigin PackumentDeps
deps ServeRuntime
rt MemoryTicket
ticket Maybe ClientCredential
clientToken PackageName
name)
            (PackumentDeps
-> ServeRuntime
-> MemoryTicket
-> PackageName
-> Handler OriginResult
fetchPublicOrigin PackumentDeps
deps ServeRuntime
rt MemoryTicket
ticket PackageName
name)

-- An explicit private refusal stops the request: no public document may stand in for it.
privateAccessRefused :: PackumentServing response -> Handler ResponseReceived
privateAccessRefused :: forall response.
PackumentServing response -> Handler ResponseReceived
privateAccessRefused PackumentServing response
serving = do
    IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> Decision -> IO ()
mpServeDecision (PackumentServing response -> MetricsPort
forall response. PackumentServing response -> MetricsPort
servingMetrics PackumentServing response
serving) Decision
Metric.Deny)
    IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> Handler ResponseReceived)
-> (response -> IO ResponseReceived)
-> response
-> Handler ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackumentServing response -> response -> IO ResponseReceived
forall response.
PackumentServing response -> response -> IO ResponseReceived
psvRespond PackumentServing response
serving (response -> Handler ResponseReceived)
-> response -> Handler ResponseReceived
forall a b. (a -> b) -> a -> b
$
        PackumentReplies response -> ResponseHeaders -> Refusal -> response
forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentForbidden (PackumentServing response -> PackumentReplies response
forall response.
PackumentServing response -> PackumentReplies response
psvReplies PackumentServing response
serving) [] (Maybe HelpMessage -> Refusal
privateAuthorisationRefusal (PackumentDeps -> Maybe HelpMessage
pdHelp (PackumentServing response -> PackumentDeps
forall response. PackumentServing response -> PackumentDeps
psvDeps PackumentServing response
serving)))

serveMergedPackument ::
    PackumentServing response ->
    EvalContext ->
    OriginResult ->
    OriginResult ->
    Handler ResponseReceived
serveMergedPackument :: forall response.
PackumentServing response
-> EvalContext
-> OriginResult
-> OriginResult
-> Handler ResponseReceived
serveMergedPackument PackumentServing response
serving EvalContext
evalCtx OriginResult
privResult OriginResult
pubResult = do
    let (Maybe Contribution
private, [ServeDecision]
privateExclusions) = MinTrustedIntegrity
-> Maybe Manifest -> (Maybe Contribution, [ServeDecision])
admitTrusted (PackumentDeps -> MinTrustedIntegrity
pdMinTrustedIntegrity PackumentDeps
deps) (OriginResult -> Maybe Manifest
originManifest OriginResult
privResult)
        trustedVersions :: Map Text PackageDetails
trustedVersions = Map Text PackageDetails
-> (Contribution -> Map Text PackageDetails)
-> Maybe Contribution
-> Map Text PackageDetails
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Text PackageDetails
forall k a. Map k a
Map.empty (PackageInfo -> Map Text PackageDetails
infoVersions (PackageInfo -> Map Text PackageDetails)
-> (Contribution -> PackageInfo)
-> Contribution
-> Map Text PackageDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contribution -> PackageInfo
srcInfo) Maybe Contribution
private
    public <- IO PublicAdmission -> Handler PublicAdmission
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TracingPort
-> MetricsPort
-> PackumentDeps
-> PackageName
-> EvalContext
-> Map Text PackageDetails
-> Maybe Manifest
-> IO PublicAdmission
gatePublic (ServeRuntime -> TracingPort
srTracing ServeRuntime
rt) (PackumentServing response -> MetricsPort
forall response. PackumentServing response -> MetricsPort
servingMetrics PackumentServing response
serving) PackumentDeps
deps PackageName
name EvalContext
evalCtx Map Text PackageDetails
trustedVersions (OriginResult -> Maybe Manifest
originManifest OriginResult
pubResult))
    let sources = [Maybe Contribution] -> [Contribution]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Contribution
private, PublicAdmission -> Maybe Contribution
paContribution PublicAdmission
public]
    case originMiss privResult of
        Just OriginMiss
miss | PackumentDeps -> PackageName -> Bool
pdFirstParty PackumentDeps
deps PackageName
name -> PackumentServing response -> OriginMiss -> Handler ResponseReceived
forall response.
PackumentServing response -> OriginMiss -> Handler ResponseReceived
firstPartyMissed PackumentServing response
serving OriginMiss
miss
        Maybe OriginMiss
_ -> case [Contribution]
-> Map Text PackageDetails
-> Map Text PackageDetails
-> Maybe MergePlan
packumentPlan [Contribution]
sources Map Text PackageDetails
trustedVersions (PublicAdmission -> Map Text PackageDetails
paDeniedEvidence PublicAdmission
public) of
            Just MergePlan
plan -> PackumentServing response
-> [Contribution] -> MergePlan -> Handler ResponseReceived
forall response.
PackumentServing response
-> [Contribution] -> MergePlan -> Handler ResponseReceived
serveResolved PackumentServing response
serving [Contribution]
sources MergePlan
plan
            Maybe MergePlan
Nothing ->
                PackumentServing response
-> Maybe DbEtag
-> [VersionVerdict]
-> [ServeDecision]
-> Handler ResponseReceived
forall response.
PackumentServing response
-> Maybe DbEtag
-> [VersionVerdict]
-> [ServeDecision]
-> Handler ResponseReceived
noServeableVersions PackumentServing response
serving (EvalContext -> Maybe DbEtag
ctxAdvisoryEtag EvalContext
evalCtx) (PublicAdmission -> [VersionVerdict]
paVerdicts PublicAdmission
public) ([ServeDecision] -> Handler ResponseReceived)
-> [ServeDecision] -> Handler ResponseReceived
forall a b. (a -> b) -> a -> b
$
                    OriginResult -> OriginResult -> [ServeDecision] -> [ServeDecision]
collectDecisions OriginResult
privResult OriginResult
pubResult ([ServeDecision]
privateExclusions [ServeDecision] -> [ServeDecision] -> [ServeDecision]
forall a. Semigroup a => a -> a -> a
<> PublicAdmission -> [ServeDecision]
paExclusions PublicAdmission
public)
  where
    deps :: PackumentDeps
deps = PackumentServing response -> PackumentDeps
forall response. PackumentServing response -> PackumentDeps
psvDeps PackumentServing response
serving
    name :: PackageName
name = PackumentServing response -> PackageName
forall response. PackumentServing response -> PackageName
psvName PackumentServing response
serving
    rt :: ServeRuntime
rt = PackumentServing response -> ServeRuntime
forall response. PackumentServing response -> ServeRuntime
psvRuntime PackumentServing response
serving

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 -> CachedDoc -> ContentDigest -> Int -> Contribution
Contribution Provenance
TrustedSource PackageInfo
admissible (Manifest -> CachedDoc
manifestRaw Manifest
manifest) (Manifest -> ContentDigest
manifestDigest Manifest
manifest) (Manifest -> Int
manifestBodyBytes Manifest
manifest)), [ServeDecision]
integrityRefusals)

data PublicAdmission = PublicAdmission
    { PublicAdmission -> Maybe Contribution
paContribution :: Maybe Contribution
    , PublicAdmission -> [ServeDecision]
paExclusions :: [ServeDecision]
    , PublicAdmission -> [VersionVerdict]
paVerdicts :: [VersionVerdict]
    , PublicAdmission -> Map Text PackageDetails
paDeniedEvidence :: Map Text PackageDetails
    -- Integrity-admitted but rule-denied versions contribute alarms, never served entries.
    }

gatePublic :: TracingPort -> MetricsPort -> PackumentDeps -> PackageName -> EvalContext -> Map Text PackageDetails -> Maybe Manifest -> IO PublicAdmission
gatePublic :: TracingPort
-> MetricsPort
-> PackumentDeps
-> PackageName
-> EvalContext
-> Map Text PackageDetails
-> Maybe Manifest
-> IO PublicAdmission
gatePublic TracingPort
tracing MetricsPort
metrics PackumentDeps
deps PackageName
name EvalContext
ctx Map Text PackageDetails
trustedVersions = \case
    Maybe Manifest
Nothing -> PublicAdmission -> IO PublicAdmission
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Contribution
-> [ServeDecision]
-> [VersionVerdict]
-> Map Text PackageDetails
-> PublicAdmission
PublicAdmission Maybe Contribution
forall a. Maybe a
Nothing [] [] Map Text PackageDetails
forall k a. Map k a
Map.empty)
    Just Manifest
manifest -> TracingPort -> forall a. PackageName -> IO a -> IO a
spanPackumentGate TracingPort
tracing PackageName
name (IO PublicAdmission -> IO PublicAdmission)
-> IO PublicAdmission -> IO PublicAdmission
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 -> FilterPlan
filterPlanFromDecisions Map Text Decision
decisions
            deniedEvidence = Map Text PackageDetails -> Set Text -> Map Text PackageDetails
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys (Map Text PackageDetails
-> Map Text PackageDetails -> Map Text PackageDetails
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
admissible) Map Text PackageDetails
trustedVersions) (FilterPlan -> Set Text
fpSurvivors FilterPlan
plan)
        pure $
            if Set.null (fpSurvivors plan)
                then
                    let verdicts = PackageInfo -> [Decision] -> [VersionVerdict]
projectDecisions PackageInfo
admissible (FilterPlan -> [Decision]
fpDecisions FilterPlan
plan)
                     in PublicAdmission Nothing (map vvDecision verdicts <> integrityRefusals) verdicts deniedEvidence
                else
                    PublicAdmission
                        (Just (Contribution GatedSource (restrictToSurvivors (fpSurvivors plan) admissible) (manifestRaw manifest) (manifestDigest manifest) (manifestBodyBytes manifest)))
                        integrityRefusals
                        []
                        deniedEvidence

decideVersions :: PackumentDeps -> EvalContext -> PackageInfo -> IO (Map Text Decision)
decideVersions :: PackumentDeps
-> EvalContext -> PackageInfo -> IO (Map Text Decision)
decideVersions PackumentDeps
deps EvalContext
ctx PackageInfo
info = do
    decide <- EvalContext -> [PreparedRule] -> IO (RuleEvidence -> IO Decision)
newEvaluator EvalContext
ctx (PackumentDeps -> [PreparedRule]
pdRules PackumentDeps
deps)
    traverse (decide . completeEvidence) (infoVersions info)

projectDecisions :: PackageInfo -> [Decision] -> [VersionVerdict]
projectDecisions :: PackageInfo -> [Decision] -> [VersionVerdict]
projectDecisions PackageInfo
info =
    ((Text, PackageDetails) -> Decision -> VersionVerdict)
-> [(Text, PackageDetails)] -> [Decision] -> [VersionVerdict]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Text, PackageDetails) -> Decision -> VersionVerdict
versionVerdict (Map Text PackageDetails -> [(Text, PackageDetails)]
forall k a. Map k a -> [(k, a)]
Map.toList (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info))
  where
    versionVerdict :: (Text, PackageDetails) -> Decision -> VersionVerdict
versionVerdict (Text
ver, PackageDetails
details) Decision
d = Text -> ServeDecision -> VersionVerdict
VersionVerdict Text
ver (PackageDetails -> Decision -> ServeDecision
serveDecisionOf PackageDetails
details Decision
d)

{- The trusted version map is the caller's own, the one the public gate was given, so the merge
and the gate can never disagree about which versions are trusted. -}
packumentPlan :: [Contribution] -> Map Text PackageDetails -> Map Text PackageDetails -> Maybe MergePlan
packumentPlan :: [Contribution]
-> Map Text PackageDetails
-> Map Text PackageDetails
-> Maybe MergePlan
packumentPlan [Contribution]
sources Map Text PackageDetails
trustedVersions Map Text PackageDetails
deniedEvidence = do
    plan <- [(Provenance, Snapshot PackageInfo)] -> Maybe MergePlan
mergePackuments [(Contribution -> Provenance
srcProvenance Contribution
s, ContentDigest -> PackageInfo -> Snapshot PackageInfo
forall a. ContentDigest -> a -> Snapshot a
Snapshot (Contribution -> ContentDigest
srcDigest Contribution
s) (Contribution -> PackageInfo
srcInfo Contribution
s)) | Contribution
s <- [Contribution]
sources]
    guard (not (Map.null (mpSurvivors plan)))
    pure plan{mpDivergences = mpDivergences plan <> integrityDivergences trustedVersions deniedEvidence}

serveResolved :: PackumentServing response -> [Contribution] -> MergePlan -> Handler ResponseReceived
serveResolved :: forall response.
PackumentServing response
-> [Contribution] -> MergePlan -> Handler ResponseReceived
serveResolved PackumentServing response
serving [Contribution]
sources MergePlan
plan = do
    MetricsPort -> PackageName -> MergePlan -> Handler ()
forall (m :: * -> *).
KatipContext m =>
MetricsPort -> PackageName -> MergePlan -> m ()
warnDivergences (PackumentServing response -> MetricsPort
forall response. PackumentServing response -> MetricsPort
servingMetrics PackumentServing response
serving) (PackumentServing response -> PackageName
forall response. PackumentServing response -> PackageName
psvName PackumentServing response
serving) MergePlan
plan
    IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> Decision -> IO ()
mpServeDecision (PackumentServing response -> MetricsPort
forall response. PackumentServing response -> MetricsPort
servingMetrics PackumentServing response
serving) Decision
Metric.Admit)
    PackumentServing response
-> [Contribution] -> MergePlan -> Handler ResponseReceived
forall response.
PackumentServing response
-> [Contribution] -> MergePlan -> Handler ResponseReceived
answerPackumentConditional PackumentServing response
serving [Contribution]
sources MergePlan
plan

{- Answer the conditional packument request before any assembly. A 304 costs the fetches
and the plan, never the document rebuild, the encode, or an output hash. -}
answerPackumentConditional :: PackumentServing response -> [Contribution] -> MergePlan -> Handler ResponseReceived
answerPackumentConditional :: forall response.
PackumentServing response
-> [Contribution] -> MergePlan -> Handler ResponseReceived
answerPackumentConditional PackumentServing response
serving [Contribution]
sources MergePlan
plan = do
    let origins :: [Text]
origins = (RegistryUrl -> Text) -> [RegistryUrl] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RegistryUrl -> Text
registryUrlText (Maybe RegistryUrl -> [RegistryUrl]
forall a. Maybe a -> [a]
maybeToList (PackumentDeps -> Maybe RegistryUrl
pdPrivateBaseUrl PackumentDeps
deps) [RegistryUrl] -> [RegistryUrl] -> [RegistryUrl]
forall a. Semigroup a => a -> a -> a
<> [PackumentDeps -> RegistryUrl
pdPublicBaseUrl PackumentDeps
deps])
        etag :: ETag
etag = Text
-> [Text]
-> PackageName
-> [(Provenance, ContentDigest, [(Text, [EntryKey])])]
-> ETag
packumentETag (PackumentDeps -> Text
pdMountBaseUrl PackumentDeps
deps) [Text]
origins PackageName
name ((Contribution -> (Provenance, ContentDigest, [(Text, [EntryKey])]))
-> [Contribution]
-> [(Provenance, ContentDigest, [(Text, [EntryKey])])]
forall a b. (a -> b) -> [a] -> [b]
map Contribution -> (Provenance, ContentDigest, [(Text, [EntryKey])])
fingerprintPiece [Contribution]
sources)
    case ResponseHeaders -> ETag -> Conditional
evaluateETag (Request -> ResponseHeaders
requestHeaders (PackumentServing response -> Request
forall response. PackumentServing response -> Request
psvRequest PackumentServing response
serving)) ETag
etag of
        NotModified ETag
matched -> 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
"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 -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (response -> IO ResponseReceived
respond (PackumentReplies response -> ResponseHeaders -> response
forall response.
PackumentReplies response -> ResponseHeaders -> response
packumentNotModified PackumentReplies response
replies [ETag -> Header
etagHeader ETag
matched]))
        Modified ETag
fresh -> 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
"serving packument for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
name))
            bytes <- IO ByteString -> Handler ByteString
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (PackumentServing response
-> [Contribution] -> MergePlan -> ETag -> IO ByteString
forall response.
PackumentServing response
-> [Contribution] -> MergePlan -> ETag -> IO ByteString
servedBytes PackumentServing response
serving [Contribution]
sources MergePlan
plan ETag
fresh)
            liftIO (respond (packumentResponse replies (psvMode serving) fresh bytes))
  where
    deps :: PackumentDeps
deps = PackumentServing response -> PackumentDeps
forall response. PackumentServing response -> PackumentDeps
psvDeps PackumentServing response
serving
    name :: PackageName
name = PackumentServing response -> PackageName
forall response. PackumentServing response -> PackageName
psvName PackumentServing response
serving
    replies :: PackumentReplies response
replies = PackumentServing response -> PackumentReplies response
forall response.
PackumentServing response -> PackumentReplies response
psvReplies PackumentServing response
serving
    respond :: response -> IO ResponseReceived
respond = PackumentServing response -> response -> IO ResponseReceived
forall response.
PackumentServing response -> response -> IO ResponseReceived
psvRespond PackumentServing response
serving

-- | A validator derived from framed inputs so unchanged requests skip assembly. Bump the salt when assembly behaviour changes.
packumentETag :: Text -> [Text] -> PackageName -> [(Provenance, ContentDigest, [(Text, [EntryKey])])] -> ETag
packumentETag :: Text
-> [Text]
-> PackageName
-> [(Provenance, ContentDigest, [(Text, [EntryKey])])]
-> ETag
packumentETag Text
mountBaseUrl [Text]
originBaseUrls PackageName
name [(Provenance, ContentDigest, [(Text, [EntryKey])])]
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 = LByteString -> [ByteString]
LBS.toChunks (Builder -> LByteString
toLazyByteString Builder
fingerprint)

    fingerprint :: Builder
    fingerprint :: Builder
fingerprint =
        Builder
"ecluse:packument-etag:v4\0"
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder) -> [Text] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ByteString -> Builder
etagFrame (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8) [Text]
originBaseUrls
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\0"
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
mountBaseUrl)
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\0"
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (PackageName -> Text
renderPackageName PackageName
name))
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\0"
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((Provenance, ContentDigest, [(Text, [EntryKey])]) -> Builder)
-> [(Provenance, ContentDigest, [(Text, [EntryKey])])] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Provenance, ContentDigest, [(Text, [EntryKey])]) -> Builder
etagSourcePiece [(Provenance, ContentDigest, [(Text, [EntryKey])])]
sources

etagSourcePiece :: (Provenance, ContentDigest, [(Text, [EntryKey])]) -> Builder
etagSourcePiece :: (Provenance, ContentDigest, [(Text, [EntryKey])]) -> Builder
etagSourcePiece (Provenance
provenance, ContentDigest
digest, [(Text, [EntryKey])]
survivors) =
    Provenance -> Builder
etagProvenanceTag Provenance
provenance
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString (ContentDigest -> ByteString
digestBytes ContentDigest
digest)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((Text, [EntryKey]) -> Builder) -> [(Text, [EntryKey])] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Text, [EntryKey]) -> Builder
etagVersionPiece [(Text, [EntryKey])]
survivors
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\1"

etagVersionPiece :: (Text, [EntryKey]) -> Builder
etagVersionPiece :: (Text, [EntryKey]) -> Builder
etagVersionPiece (Text
version, [EntryKey]
entries) =
    ByteString -> Builder
etagFrame (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
version) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (EntryKey -> Builder) -> [EntryKey] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap EntryKey -> Builder
etagEntryPiece [EntryKey]
entries Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\2"

etagEntryPiece :: EntryKey -> Builder
etagEntryPiece :: EntryKey -> Builder
etagEntryPiece = \case
    ArrayEntry Int
index -> Builder
"a" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
etagFrame (Int -> ByteString
forall b a. (Show a, IsString b) => a -> b
show Int
index)
    ObjectEntry Text
key -> Builder
"o" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
etagFrame (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
key)
    EntryKey
SingletonEntry -> Builder
"s"

etagFrame :: ByteString -> Builder
etagFrame :: ByteString -> Builder
etagFrame ByteString
bytes = Int -> Builder
intDec (ByteString -> Int
BS.length ByteString
bytes) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
bytes

etagProvenanceTag :: Provenance -> Builder
etagProvenanceTag :: Provenance -> Builder
etagProvenanceTag = \case
    Provenance
TrustedSource -> Builder
"t\0"
    Provenance
GatedSource -> Builder
"g\0"

-- Distinct private views produce distinct cache keys. A cache miss pays for the merged document and
-- its encoding before either exists, and wraps a render escape, which breaks the totality contract.
servedBytes :: PackumentServing response -> [Contribution] -> MergePlan -> ETag -> IO ByteString
servedBytes :: forall response.
PackumentServing response
-> [Contribution] -> MergePlan -> ETag -> IO ByteString
servedBytes PackumentServing response
serving [Contribution]
sources MergePlan
plan ETag
etag =
    MemoryTicket -> FlightKey -> IO ByteString -> IO ByteString
forall (m :: * -> *) a.
MonadUnliftIO m =>
MemoryTicket -> FlightKey -> m a -> m a
awaitingFlight (PackumentServing response -> MemoryTicket
forall response. PackumentServing response -> MemoryTicket
psvTicket PackumentServing response
serving) FlightKey
flight (IO ByteString -> IO ByteString)
-> (IO ByteString -> IO ByteString)
-> IO ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetricsPort
-> MetadataCache -> Text -> IO ByteString -> IO ByteString
resolveAssembled (ServeRuntime -> MetricsPort
srMetrics ServeRuntime
rt) (ServeRuntime -> MetadataCache
srMetadataCache ServeRuntime
rt) Text
key (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
        MemoryTicket -> Int -> IO ()
charge (FlightKey -> MemoryTicket -> MemoryTicket
servingFlight FlightKey
flight (PackumentServing response -> MemoryTicket
forall response. PackumentServing response -> MemoryTicket
psvTicket PackumentServing response
serving)) Int
outputCharge
        IO ByteString -> IO ByteString
markRenderEscape (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
            (RenderRefused -> IO ByteString)
-> (LByteString -> IO ByteString)
-> Either RenderRefused LByteString
-> IO ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either RenderRefused -> IO ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (\LByteString
body -> 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 LByteString
body) (AdapterMetadata -> CachedDoc -> Either RenderRefused LByteString
metadataSerialise (PackumentDeps -> AdapterMetadata
pdMetadata PackumentDeps
deps) (PackumentDeps -> [Contribution] -> MergePlan -> CachedDoc
renderServedBody PackumentDeps
deps [Contribution]
sources MergePlan
plan))
  where
    rt :: ServeRuntime
rt = PackumentServing response -> ServeRuntime
forall response. PackumentServing response -> ServeRuntime
psvRuntime PackumentServing response
serving
    deps :: PackumentDeps
deps = PackumentServing response -> PackumentDeps
forall response. PackumentServing response -> PackumentDeps
psvDeps PackumentServing response
serving
    key :: Text
key = ETag -> Text
renderETag ETag
etag
    flight :: FlightKey
flight = Text -> FlightKey
FlightKey (Text
"assembled " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key)
    outputCharge :: Int
outputCharge = Int -> Int -> Int
scaleCharge (ChargeFactors -> Int
cfOutputPermille (AdapterMetadata -> ChargeFactors
metadataChargeFactors (PackumentDeps -> AdapterMetadata
pdMetadata PackumentDeps
deps))) (MergePlan -> [Contribution] -> Int
outputBasisBytes MergePlan
plan [Contribution]
sources)
    markRenderEscape :: IO ByteString -> IO ByteString
    markRenderEscape :: IO ByteString -> IO ByteString
markRenderEscape IO ByteString
render = IO ByteString
render IO ByteString -> (SomeException -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (RenderEscape -> IO ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (RenderEscape -> IO ByteString)
-> (SomeException -> RenderEscape)
-> SomeException
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> RenderEscape
RenderEscape)

{- | The source bytes a listing's output charge scales: the larger of two estimates, anchored on the
largest source and on the base document, each adding the others' bytes pro rata for versions it lacks.
-}
outputBasisBytes :: MergePlan -> [Contribution] -> Int
outputBasisBytes :: MergePlan -> [Contribution] -> Int
outputBasisBytes MergePlan
plan [Contribution]
sources = (Int -> Int -> Int) -> Int -> [Int] -> 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 -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (((Int, Contribution) -> Int) -> [(Int, Contribution)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Contribution) -> Int
anchoredOn [(Int, Contribution)]
anchors)
  where
    indexed :: [(Int, Contribution)]
indexed = [Int] -> [Contribution] -> [(Int, Contribution)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Contribution]
sources
    anchors :: [(Int, Contribution)]
anchors = Maybe (Int, Contribution) -> [(Int, Contribution)]
forall a. Maybe a -> [a]
maybeToList ([(Int, Contribution)] -> Maybe (Int, Contribution)
forall a. [a] -> Maybe a
listToMaybe (((Int, Contribution) -> Down Int)
-> [(Int, Contribution)] -> [(Int, Contribution)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int)
-> ((Int, Contribution) -> Int) -> (Int, Contribution) -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contribution -> Int
srcBodyBytes (Contribution -> Int)
-> ((Int, Contribution) -> Contribution)
-> (Int, Contribution)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Contribution) -> Contribution
forall a b. (a, b) -> b
snd) [(Int, Contribution)]
indexed)) [(Int, Contribution)]
-> [(Int, Contribution)] -> [(Int, Contribution)]
forall a. Semigroup a => a -> a -> a
<> Maybe (Int, Contribution) -> [(Int, Contribution)]
forall a. Maybe a -> [a]
maybeToList ([(Int, Contribution)] -> Maybe (Int, Contribution)
baseSource [(Int, Contribution)]
indexed)
    anchoredOn :: (Int, Contribution) -> Int
anchoredOn (Int
position, Contribution
anchor) =
        Contribution -> Int
srcBodyBytes Contribution
anchor Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum [Int -> Contribution -> Int
addedShare (Map Text Int -> Int
forall k a. Map k a -> Int
Map.size (MergePlan -> Map Text Int
mpSurvivors MergePlan
plan) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Contribution -> Int
versionCount Contribution
anchor) Contribution
other | (Int
at, Contribution
other) <- [(Int, Contribution)]
indexed, Int
at Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
position]

-- A source's bytes pro rata for the survivors outside the anchor, rounded up.
addedShare :: Int -> Contribution -> Int
addedShare :: Int -> Contribution -> Int
addedShare Int
outside Contribution
source
    | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Contribution -> Int
srcBodyBytes Contribution
source
    | Bool
otherwise = (Contribution -> Int
srcBodyBytes Contribution
source Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
count (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
outside) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
count
  where
    count :: Int
count = Contribution -> Int
versionCount Contribution
source

versionCount :: Contribution -> Int
versionCount :: Contribution -> Int
versionCount = Map Text PackageDetails -> Int
forall k a. Map k a -> Int
Map.size (Map Text PackageDetails -> Int)
-> (Contribution -> Map Text PackageDetails) -> Contribution -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageInfo -> Map Text PackageDetails
infoVersions (PackageInfo -> Map Text PackageDetails)
-> (Contribution -> PackageInfo)
-> Contribution
-> Map Text PackageDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contribution -> PackageInfo
srcInfo

renderServedBody :: PackumentDeps -> [Contribution] -> MergePlan -> CachedDoc
renderServedBody :: PackumentDeps -> [Contribution] -> MergePlan -> CachedDoc
renderServedBody PackumentDeps
deps = AdapterMetadata -> Text -> [Contribution] -> MergePlan -> CachedDoc
assembleServedBody (PackumentDeps -> AdapterMetadata
pdMetadata PackumentDeps
deps) (PackumentDeps -> Text
pdMountBaseUrl PackumentDeps
deps)

-- | The served document of a merge whose plan names the sources by their position.
assembleServedBody :: AdapterMetadata -> Text -> [Contribution] -> MergePlan -> CachedDoc
assembleServedBody :: AdapterMetadata -> Text -> [Contribution] -> MergePlan -> CachedDoc
assembleServedBody AdapterMetadata
metadata Text
mountBase [Contribution]
sources MergePlan
plan =
    AdapterMetadata
-> Text
-> Map Int (Snapshot CachedDoc)
-> MergePlan
-> Maybe CachedDoc
-> CachedDoc
metadataAssemble AdapterMetadata
metadata Text
mountBase Map Int (Snapshot CachedDoc)
bySource MergePlan
plan ([Contribution] -> Maybe CachedDoc
baseDocument [Contribution]
sources)
  where
    bySource :: Map SourceId (Snapshot CachedDoc)
    bySource :: Map Int (Snapshot CachedDoc)
bySource = [(Int, Snapshot CachedDoc)] -> Map Int (Snapshot CachedDoc)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Int] -> [Snapshot CachedDoc] -> [(Int, Snapshot CachedDoc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [ContentDigest -> CachedDoc -> Snapshot CachedDoc
forall a. ContentDigest -> a -> Snapshot a
Snapshot (Contribution -> ContentDigest
srcDigest Contribution
source) (Contribution -> CachedDoc
srcValue Contribution
source) | Contribution
source <- [Contribution]
sources])

baseDocument :: [Contribution] -> Maybe CachedDoc
baseDocument :: [Contribution] -> Maybe CachedDoc
baseDocument = ((Int, Contribution) -> CachedDoc)
-> Maybe (Int, Contribution) -> Maybe CachedDoc
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Contribution -> CachedDoc
srcValue (Contribution -> CachedDoc)
-> ((Int, Contribution) -> Contribution)
-> (Int, Contribution)
-> CachedDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Contribution) -> Contribution
forall a b. (a, b) -> b
snd) (Maybe (Int, Contribution) -> Maybe CachedDoc)
-> ([Contribution] -> Maybe (Int, Contribution))
-> [Contribution]
-> Maybe CachedDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Contribution)] -> Maybe (Int, Contribution)
baseSource ([(Int, Contribution)] -> Maybe (Int, Contribution))
-> ([Contribution] -> [(Int, Contribution)])
-> [Contribution]
-> Maybe (Int, Contribution)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Contribution] -> [(Int, Contribution)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..]

-- The source whose top-level fields the served document keeps: the trusted one, else the first.
baseSource :: [(Int, Contribution)] -> Maybe (Int, Contribution)
baseSource :: [(Int, Contribution)] -> Maybe (Int, Contribution)
baseSource [(Int, Contribution)]
indexed = ((Int, Contribution) -> Bool)
-> [(Int, Contribution)] -> Maybe (Int, 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)
-> ((Int, Contribution) -> Provenance)
-> (Int, Contribution)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contribution -> Provenance
srcProvenance (Contribution -> Provenance)
-> ((Int, Contribution) -> Contribution)
-> (Int, Contribution)
-> Provenance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Contribution) -> Contribution
forall a b. (a, b) -> b
snd) [(Int, Contribution)]
indexed Maybe (Int, Contribution)
-> Maybe (Int, Contribution) -> Maybe (Int, Contribution)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(Int, Contribution)] -> Maybe (Int, Contribution)
forall a. [a] -> Maybe a
listToMaybe [(Int, Contribution)]
indexed

packumentResponse :: PackumentReplies response -> PackumentServe -> ETag -> ByteString -> response
packumentResponse :: forall response.
PackumentReplies response
-> PackumentServe -> ETag -> ByteString -> response
packumentResponse PackumentReplies response
replies PackumentServe
mode ETag
etag ByteString
bytes = case PackumentServe
mode of
    PackumentServe
PackumentFull ->
        PackumentReplies response
-> ResponseHeaders -> LByteString -> response
forall response.
PackumentReplies response
-> ResponseHeaders -> LByteString -> response
packumentOk PackumentReplies response
replies [ETag -> Header
etagHeader ETag
etag] (ByteString -> LByteString
LBS.fromStrict ByteString
bytes)
    PackumentServe
PackumentHead ->
        PackumentReplies response
-> ResponseHeaders -> LByteString -> response
forall response.
PackumentReplies response
-> ResponseHeaders -> LByteString -> response
packumentOk
            PackumentReplies response
replies
            [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 status folds the decision list once and both the metric and the response read that value.
noServeableVersions ::
    PackumentServing response ->
    Maybe DbEtag ->
    [VersionVerdict] ->
    [ServeDecision] ->
    Handler ResponseReceived
noServeableVersions :: forall response.
PackumentServing response
-> Maybe DbEtag
-> [VersionVerdict]
-> [ServeDecision]
-> Handler ResponseReceived
noServeableVersions PackumentServing response
serving Maybe DbEtag
etag [VersionVerdict]
verdicts [ServeDecision]
decisions = 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 (PackumentStatus -> Decision
statusServeDecision PackumentStatus
status))
    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)
    PackageName -> Maybe DbEtag -> [VersionVerdict] -> Handler ()
forall (m :: * -> *).
KatipContext m =>
PackageName -> Maybe DbEtag -> [VersionVerdict] -> m ()
logDenials (PackumentServing response -> PackageName
forall response. PackumentServing response -> PackageName
psvName PackumentServing response
serving) Maybe DbEtag
etag [VersionVerdict]
verdicts
    IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (PackumentServing response -> response -> IO ResponseReceived
forall response.
PackumentServing response -> response -> IO ResponseReceived
psvRespond PackumentServing response
serving (PackumentReplies response
-> PackumentDeps -> PackumentStatus -> [ServeDecision] -> response
forall response.
PackumentReplies response
-> PackumentDeps -> PackumentStatus -> [ServeDecision] -> response
noSurvivors (PackumentServing response -> PackumentReplies response
forall response.
PackumentServing response -> PackumentReplies response
psvReplies PackumentServing response
serving) (PackumentServing response -> PackumentDeps
forall response. PackumentServing response -> PackumentDeps
psvDeps PackumentServing response
serving) PackumentStatus
status [ServeDecision]
decisions))
  where
    metrics :: MetricsPort
metrics = PackumentServing response -> MetricsPort
forall response. PackumentServing response -> MetricsPort
servingMetrics PackumentServing response
serving
    status :: PackumentStatus
status = [ServeDecision] -> PackumentStatus
packumentStatus [ServeDecision]
decisions

noSurvivors :: PackumentReplies response -> PackumentDeps -> PackumentStatus -> [ServeDecision] -> response
noSurvivors :: forall response.
PackumentReplies response
-> PackumentDeps -> PackumentStatus -> [ServeDecision] -> response
noSurvivors PackumentReplies response
replies PackumentDeps
deps PackumentStatus
status [ServeDecision]
decisions = case PackumentStatus
status of
    PackumentStatus
PackumentOk -> PackumentReplies response -> ResponseHeaders -> Refusal -> response
forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentInternal PackumentReplies response
replies [] Refusal
body
    PackumentStatus
PackumentForbidden -> PackumentReplies response -> ResponseHeaders -> Refusal -> response
forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentForbidden PackumentReplies response
replies [] Refusal
body
    PackumentUnavailable Maybe RetryAfter
retry -> PackumentReplies response -> ResponseHeaders -> Refusal -> response
forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentUnavailable PackumentReplies response
replies (Maybe RetryAfter -> ResponseHeaders
retryAfterHeaders Maybe RetryAfter
retry) Refusal
body
    PackumentStatus
PackumentBadGateway -> PackumentReplies response -> ResponseHeaders -> Refusal -> response
forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentBadGateway PackumentReplies response
replies [] Refusal
body
    PackumentStatus
PackumentServerError -> PackumentReplies response -> ResponseHeaders -> Refusal -> response
forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentInternal PackumentReplies response
replies [] Refusal
body
  where
    -- An empty reason 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

    body :: Refusal
body = Maybe HelpMessage -> Text -> Refusal
mkRefusal (PackumentDeps -> Maybe HelpMessage
pdHelp PackumentDeps
deps) Text
message

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)

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

privateDecision :: OriginResult -> [ServeDecision]
privateDecision :: OriginResult -> [ServeDecision]
privateDecision = \case
    OriginAuthorisationFailure Int
_ -> []
    OriginResolved Manifest
_ -> []
    -- A merged name keeps a private 404 and a private outage on one refusal, so a name
    -- neither leg could serve still invites a retry.
    OriginResult
OriginNotFound -> [ServeDecision
neededUpstreamUnavailable]
    OriginResult
OriginUnresolved -> [ServeDecision
neededUpstreamUnavailable]
    OriginResult
OriginNameMismatch -> [ServeDecision
upstreamInvalidDecision]
    -- An unconfigured private leg (a serve-only pure gate) is not an outage:
    -- nothing was needed, so nothing is unavailable.
    OriginResult
OriginAbsent -> []

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

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

firstPartyMissed :: PackumentServing response -> OriginMiss -> Handler ResponseReceived
firstPartyMissed :: forall response.
PackumentServing response -> OriginMiss -> Handler ResponseReceived
firstPartyMissed PackumentServing response
serving OriginMiss
miss = 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 ([ServeDecision] -> Decision
packumentServeDecision [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 (IO ResponseReceived -> Handler ResponseReceived)
-> (response -> IO ResponseReceived)
-> response
-> Handler ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackumentServing response -> response -> IO ResponseReceived
forall response.
PackumentServing response -> response -> IO ResponseReceived
psvRespond PackumentServing response
serving (response -> Handler ResponseReceived)
-> response -> Handler ResponseReceived
forall a b. (a -> b) -> a -> b
$
        PackumentReplies response
-> Maybe HelpMessage -> PackageName -> OriginMiss -> response
forall response.
PackumentReplies response
-> Maybe HelpMessage -> PackageName -> OriginMiss -> response
firstPartyMissReply (PackumentServing response -> PackumentReplies response
forall response.
PackumentServing response -> PackumentReplies response
psvReplies PackumentServing response
serving) (PackumentDeps -> Maybe HelpMessage
pdHelp (PackumentServing response -> PackumentDeps
forall response. PackumentServing response -> PackumentDeps
psvDeps PackumentServing response
serving)) PackageName
name OriginMiss
miss
  where
    metrics :: MetricsPort
metrics = PackumentServing response -> MetricsPort
forall response. PackumentServing response -> MetricsPort
servingMetrics PackumentServing response
serving
    name :: PackageName
name = PackumentServing response -> PackageName
forall response. PackumentServing response -> PackageName
psvName PackumentServing response
serving
    decision :: ServeDecision
decision = PackageName -> OriginMiss -> ServeDecision
firstPartyMissDecision PackageName
name OriginMiss
miss

-- Why a first-party name did not resolve, in the words the client reads.
firstPartyMissMessage :: PackageName -> OriginMiss -> Text
firstPartyMissMessage :: PackageName -> OriginMiss -> Text
firstPartyMissMessage PackageName
name = \case
    OriginMiss
MissAbsent ->
        Text
"'"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rendered
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' did not resolve from the private upstream, and its namespace is first-party to this deployment, so it is never fetched from the public registry"
    OriginMiss
MissUnresolved ->
        Text
"the private upstream did not answer for '"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rendered
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"', and its namespace is first-party to this deployment, so no public document may stand in for it"
  where
    rendered :: Text
rendered = PackageName -> Text
renderPackageName PackageName
name

-- | Classify a first-party absence as a policy refusal and an unread origin as an outage.
firstPartyMissDecision :: PackageName -> OriginMiss -> ServeDecision
firstPartyMissDecision :: PackageName -> OriginMiss -> ServeDecision
firstPartyMissDecision PackageName
name OriginMiss
miss = Rejection -> ServeDecision
Reject (RejectReason -> Text -> Rejection
Rejection RejectReason
reason (PackageName -> OriginMiss -> Text
firstPartyMissMessage PackageName
name OriginMiss
miss))
  where
    reason :: RejectReason
reason = case OriginMiss
miss of
        OriginMiss
MissAbsent -> RuleName -> RejectReason
ByPolicy RuleName
firstPartyRule
        OriginMiss
MissUnresolved -> Transience -> RejectReason
Unavailable (Maybe RetryAfter -> Transience
WillResolve Maybe RetryAfter
forall a. Maybe a
Nothing)

-- | Render a settled absence as @404@ and an unread origin as @503@ without @Retry-After@.
firstPartyMissReply :: PackumentReplies response -> Maybe HelpMessage -> PackageName -> OriginMiss -> response
firstPartyMissReply :: forall response.
PackumentReplies response
-> Maybe HelpMessage -> PackageName -> OriginMiss -> response
firstPartyMissReply PackumentReplies response
replies Maybe HelpMessage
help PackageName
name OriginMiss
miss = case OriginMiss
miss of
    OriginMiss
MissAbsent -> PackumentReplies response -> ResponseHeaders -> Refusal -> response
forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentNotFound PackumentReplies response
replies [] Refusal
body
    OriginMiss
MissUnresolved -> PackumentReplies response -> ResponseHeaders -> Refusal -> response
forall response.
PackumentReplies response -> ResponseHeaders -> Refusal -> response
packumentUnavailable PackumentReplies response
replies [] Refusal
body
  where
    body :: Refusal
body = Maybe HelpMessage -> Text -> Refusal
mkRefusal Maybe HelpMessage
help (PackageName -> OriginMiss -> Text
firstPartyMissMessage PackageName
name OriginMiss
miss)