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

{- | The pure HTTP relay-mechanics behind the tarball pipeline: the serve-mode plumbing
that shapes an upstream artifact request, the dispatch that relays its response, and the
verdict that judges a public relay from its status and headers alone.

These are the artifact path's transport mechanics, factored out of the
'Ecluse.Core.Server.Pipeline.Tarball' handler orchestration. They operate on
'Status', 'ResponseHeaders', and 'Network.HTTP.Client.Request' values and the metrics
and log ports, and touch neither the 'Ecluse.Core.Server.Context.Handler' reader nor the
mount's 'Ecluse.Core.Server.Context.PackumentDeps'. The handler half composes them
one-way, adapting its route-owned replies onto the 'RelayResponder' this layer drives.
-}
module Ecluse.Core.Server.Pipeline.Tarball.Relay (
    -- * Serve mode
    ArtifactServe (..),

    -- * Shaping the upstream artifact request
    withMethod,
    withValidators,

    -- * Relaying the upstream response
    relayUpstreamWhen,
    acceptArtifact,
    relayArtifact,

    -- * Judging the public relay
    RelayVerdict (..),
    relayVerdict,
    observeRelayAnomaly,
) where

import Network.HTTP.Client (Manager)
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Types (RequestHeaders, ResponseHeaders, Status, hContentType, methodHead, statusCode, statusIsSuccessful)

import Data.ByteString qualified as BS
import Ecluse.Core.Package (PackageName, renderPackageName)
import Ecluse.Core.Server.Conditional (isNotModified)
import Ecluse.Core.Server.Stream (RelayResponder, probeUpstreamWhen, streamUpstreamWhen)
import Ecluse.Core.Telemetry.Metrics qualified as Metric
import Ecluse.Core.Telemetry.Record (MetricsPort (mpPublicRelayAnomaly))
import Ecluse.Core.Version (Version, renderVersion)
import Katip (KatipContext, Severity (WarningS), katipAddContext, logFM, ls, sl)

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

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

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

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

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

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

{- | What the public leg relayed, judged at relay time from the status and headers
alone -- the body always relays verbatim, and client-side plus worker
@dist.integrity@ verification stay the guarantors of the bytes. Header-only by
design: nothing here hashes, buffers, or inspects a body, and the private leg
computes no verdict at all.

The verdict's consumer side: a non-'RelayedArtifact' is logged and counted
(@ecluse.serve.relay.anomalies@), and only a 'RelayedArtifact' enqueues the
demand-driven mirror job -- a relayed upstream miss used to enqueue a doomed job
that the worker could only drop after a metadata round trip.
-}
data RelayVerdict
    = {- | A success whose headers look like the admitted artifact (a relayed
      @304@ counts: the validators matched, nothing odd).
      -}
      RelayedArtifact
    | -- | A success that does not look like an artifact (carried, bounded reason).
      RelayedOddShape Text
    | -- | A non-success passed through verbatim (carried).
      RelayedNonSuccess Status
    deriving stock (RelayVerdict -> RelayVerdict -> Bool
(RelayVerdict -> RelayVerdict -> Bool)
-> (RelayVerdict -> RelayVerdict -> Bool) -> Eq RelayVerdict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RelayVerdict -> RelayVerdict -> Bool
== :: RelayVerdict -> RelayVerdict -> Bool
$c/= :: RelayVerdict -> RelayVerdict -> Bool
/= :: RelayVerdict -> RelayVerdict -> Bool
Eq, Int -> RelayVerdict -> ShowS
[RelayVerdict] -> ShowS
RelayVerdict -> String
(Int -> RelayVerdict -> ShowS)
-> (RelayVerdict -> String)
-> ([RelayVerdict] -> ShowS)
-> Show RelayVerdict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RelayVerdict -> ShowS
showsPrec :: Int -> RelayVerdict -> ShowS
$cshow :: RelayVerdict -> String
show :: RelayVerdict -> String
$cshowList :: [RelayVerdict] -> ShowS
showList :: [RelayVerdict] -> ShowS
Show)

{- | Judge one public relay from its status and headers. A @304@ is a clean
pass-through (the relayed validators matched); any other non-2xx is the relayed
non-success; a 2xx whose @Content-Type@ is textual (@text\/*@, or JSON where a
tarball was admitted) is the odd shape -- an upstream answering a success that is
visibly not the artifact. An absent or binary content type is taken as the
artifact: this is a header-only tripwire, not a validator (integrity
verification owns the bytes).

The admitted metadata's declared size is deliberately __not__ compared against
@Content-Length@: for npm the declared size is the unpacked-tree size
(@dist.unpackedSize@), which never equals the transfer length, so the comparison
would flag every healthy relay.
-}
relayVerdict :: Status -> ResponseHeaders -> RelayVerdict
relayVerdict :: Status -> RequestHeaders -> RelayVerdict
relayVerdict Status
status RequestHeaders
headers
    | Status -> Bool
isNotModified Status
status = RelayVerdict
RelayedArtifact
    | Bool -> Bool
not (Status -> Bool
statusIsSuccessful Status
status) = Status -> RelayVerdict
RelayedNonSuccess Status
status
    | Just ByteString
contentType <- Header -> ByteString
forall a b. (a, b) -> b
snd (Header -> ByteString) -> Maybe Header -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Header -> Bool) -> RequestHeaders -> Maybe Header
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hContentType) (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst) RequestHeaders
headers
    , ByteString -> Bool
textualContentType ByteString
contentType =
        Text -> RelayVerdict
RelayedOddShape (Text
"a success carrying a non-artifact content type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
contentType)
    | Bool
otherwise = RelayVerdict
RelayedArtifact
  where
    textualContentType :: ByteString -> Bool
textualContentType ByteString
raw =
        ByteString
"text/" ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
raw Bool -> Bool -> Bool
|| ByteString
"application/json" ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
raw

{- Observe one public-relay verdict on its consumer side: a clean artifact relay
is silent; an anomaly is counted on the bounded @ecluse.serve.relay.anomalies@
metric and logged WARNING with the package coordinates (the unbounded detail
stays on the log line, never a label). The verdict never changes what the client
received -- the body already relayed verbatim. -}
observeRelayAnomaly :: forall m. (KatipContext m) => MetricsPort -> PackageName -> Version -> RelayVerdict -> m ()
observeRelayAnomaly :: forall (m :: * -> *).
KatipContext m =>
MetricsPort -> PackageName -> Version -> RelayVerdict -> m ()
observeRelayAnomaly MetricsPort
metrics PackageName
name Version
version = \case
    RelayVerdict
RelayedArtifact -> m ()
forall (f :: * -> *). Applicative f => f ()
pass
    RelayedOddShape Text
reason -> RelayAnomaly -> Text -> m ()
record RelayAnomaly
Metric.RelayOddShape (Text
"the public upstream answered a success that does not look like the admitted artifact: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason)
    RelayedNonSuccess Status
status -> RelayAnomaly -> Text -> m ()
record RelayAnomaly
Metric.RelayNonSuccess (Text
"the public upstream answered a non-success, relayed verbatim: HTTP " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (Status -> Int
statusCode Status
status))
  where
    record :: Metric.RelayAnomaly -> Text -> m ()
    record :: RelayAnomaly -> Text -> m ()
record RelayAnomaly
cls Text
message = do
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> RelayAnomaly -> IO ()
mpPublicRelayAnomaly MetricsPort
metrics RelayAnomaly
cls)
        SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message))
    payload :: SimpleLogPayload
payload =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" (Text
"Ecluse.Core.Server.Pipeline.Tarball.Relay" :: Text)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"version" (Version -> Text
renderVersion Version
version)