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

{- | Request shaping and response classification for artifact relays.
Response judgements precede the client response commit.
-}
module Ecluse.Core.Server.Pipeline.Tarball.Relay (
    -- * Serve mode
    ArtifactServe (..),

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

    -- * Relaying the upstream response
    relayUpstreamWhen,
    acceptArtifact,
    relayUnjudged,
    relayJudged,

    -- * 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.Security (ProgressFloor)
import Ecluse.Core.Server.Conditional (isNotModified)
import Ecluse.Core.Server.Stream (RelayResponder, UpstreamBody (NoBody, StreamBody), withUpstreamWhen)
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, threaded through the artifact path so @GET@ and @HEAD@ share one
gate and one upstream-request construction.
-}
data ArtifactServe
    = -- | A @GET@: stream the artifact body through, enqueuing a mirror job on a public admit.
      ServeFull
    | {- | A @HEAD@: probe upstream as a @HEAD@ and relay the headers with no body. It serves no
      bytes, so it mirrors nothing.
      -}
      ServeHead

-- | Tag an upstream artifact request with the serve mode's method. 'ServeFull' keeps the @GET@.
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 onto an upstream artifact request, so upstream can
answer a @304 Not Modified@ instead of resending an unchanged body.
-}
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. Both modes keep the same
recoverable-miss and committed split, so a @HEAD@ falls through a private miss as a @GET@ does.
-}
relayUpstreamWhen ::
    ArtifactServe ->
    Manager ->
    ProgressFloor ->
    HTTP.Request ->
    (Status -> Bool) ->
    (Status -> ResponseHeaders -> IO (Status, ResponseHeaders, verdict)) ->
    RelayResponder response ->
    IO (Maybe (verdict, response))
relayUpstreamWhen :: forall verdict response.
ArtifactServe
-> Manager
-> ProgressFloor
-> Request
-> (Status -> Bool)
-> (Status
    -> RequestHeaders -> IO (Status, RequestHeaders, verdict))
-> RelayResponder response
-> IO (Maybe (verdict, response))
relayUpstreamWhen ArtifactServe
mode Manager
manager ProgressFloor
progress Request
request =
    Manager
-> ProgressFloor
-> Request
-> UpstreamBody
-> (Status -> Bool)
-> (Status
    -> RequestHeaders -> IO (Status, RequestHeaders, verdict))
-> RelayResponder response
-> IO (Maybe (verdict, response))
forall verdict response.
Manager
-> ProgressFloor
-> Request
-> UpstreamBody
-> (Status -> Bool)
-> (Status
    -> RequestHeaders -> IO (Status, RequestHeaders, verdict))
-> RelayResponder response
-> IO (Maybe (verdict, response))
withUpstreamWhen Manager
manager ProgressFloor
progress Request
request (UpstreamBody
 -> (Status -> Bool)
 -> (Status
     -> RequestHeaders -> IO (Status, RequestHeaders, verdict))
 -> RelayResponder response
 -> IO (Maybe (verdict, response)))
-> UpstreamBody
-> (Status -> Bool)
-> (Status
    -> RequestHeaders -> IO (Status, RequestHeaders, verdict))
-> RelayResponder response
-> IO (Maybe (verdict, response))
forall a b. (a -> b) -> a -> b
$ case ArtifactServe
mode of
        ArtifactServe
ServeFull -> UpstreamBody
StreamBody
        ArtifactServe
ServeHead -> UpstreamBody
NoBody

-- | A successful artifact response, including a matching conditional validator.
acceptArtifact :: Status -> Bool
acceptArtifact :: Status -> Bool
acceptArtifact Status
s = Status -> Bool
statusIsSuccessful Status
s Bool -> Bool -> Bool
|| Status -> Bool
isNotModified Status
s

{- | The trusted leg's pre-commit relay. It judges nothing, so the private path pays no header
scan for an anomaly only the public leg can have.
-}
relayUnjudged :: Status -> ResponseHeaders -> IO (Status, ResponseHeaders, ())
relayUnjudged :: Status -> RequestHeaders -> IO (Status, RequestHeaders, ())
relayUnjudged Status
status RequestHeaders
headers = (Status, RequestHeaders, ()) -> IO (Status, RequestHeaders, ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status
status, RequestHeaders -> RequestHeaders
forwardedHeaders RequestHeaders
headers, ())

{- | The public leg's pre-commit relay. The verdict is decided before any body moves, so a
committed relay always carries exactly one.
-}
relayJudged :: Status -> ResponseHeaders -> IO (Status, ResponseHeaders, RelayVerdict)
relayJudged :: Status
-> RequestHeaders -> IO (Status, RequestHeaders, RelayVerdict)
relayJudged Status
status RequestHeaders
headers = (Status, RequestHeaders, RelayVerdict)
-> IO (Status, RequestHeaders, RelayVerdict)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status
status, RequestHeaders -> RequestHeaders
forwardedHeaders RequestHeaders
headers, Status -> RequestHeaders -> RelayVerdict
relayVerdict Status
status RequestHeaders
headers)

{- Drop only the hop-by-hop framing headers. The content headers and the @ETag@ pass through, so
the client can verify the bytes. -}
forwardedHeaders :: ResponseHeaders -> ResponseHeaders
forwardedHeaders :: RequestHeaders -> RequestHeaders
forwardedHeaders = (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)
  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.
data RelayVerdict
    = -- | A success whose headers look like the admitted artifact. A relayed @304@ counts.
      RelayedArtifact
    | -- | A success that does not look like an artifact. Carries a bounded reason.
      RelayedOddShape Text
    | -- | A non-success passed through verbatim. Carries the status.
      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 alone.
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. An anomaly counts on the bounded
@ecluse.serve.relay.anomalies@ metric, and the unbounded detail stays on the log line.
-}
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)