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

{- | The serve path behind the first-party publish route: @PUT \/{pkg}@.

This module handles the publish flow: it validates edge authentication, applies
anti-shadowing scope guards to ensure the package name is permitted for publication,
bounds the request body at the per-request size cap (a declared over-cap length fails
closed up front; a chunked body is bounded by a counted read, both answered @413@),
enforces body-name agreement between the URL path and the publish document, and
relays the request to the upstream publication target with the publisher's credential.
-}
module Ecluse.Core.Server.Pipeline.Publish (
    PublishReplies (..),

    -- * The first-party publish handler
    servePublish,
) where

import Data.ByteString.Lazy qualified as LBS

import Network.HTTP.Types (ResponseHeaders, Status, mkStatus, status403, status405, status413, status500, status502)
import Network.Wai (Request, RequestBodyLength (ChunkedBody, KnownLength), ResponseReceived, getRequestBodyChunk, requestBodyLength)

import Ecluse.Core.Package (
    PackageName,
    Scope,
    pkgNamespace,
    renderPackageName,
 )
import Ecluse.Core.Registry (PublishRelayFault (RelayBoundExceeded, RelayTransport, RelayUrlUnformable), PublishRelayResponse (PublishRelayResponse))
import Ecluse.Core.Security (Limits (maxBodyBytes), boundedRead)
import Ecluse.Core.Server.Admission.Bytes (withByteAdmission)
import Ecluse.Core.Server.Context (
    Handler,
    MountBinding (bindingPublishDeps),
    PublishDeps (..),
    ServeRuntime (srMetrics, srPrivateManager),
    ctxMount,
    ctxRuntime,
 )
import Ecluse.Core.Server.Pipeline.Shared
import Ecluse.Core.Server.Response (appendHelp)

{- | The route-owned ways the publish pipeline may answer. The configured target may
return any status, so npm supplies these constructors from an explicit OpenAPI @default@
contract whose media type remains @application/json@.
-}
data PublishReplies response = PublishReplies
    { forall response.
PublishReplies response
-> Status -> ResponseHeaders -> LByteString -> response
publishRelayed :: Status -> ResponseHeaders -> LByteString -> response
    -- ^ Relay the publication target's status and bytes.
    , forall response.
PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
publishError :: Status -> ResponseHeaders -> Text -> response
    -- ^ Emit an ecosystem-shaped local error.
    }

servePublish ::
    PublishReplies response ->
    PackageName ->
    Request ->
    (response -> IO ResponseReceived) ->
    Handler ResponseReceived
servePublish :: forall response.
PublishReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
servePublish PublishReplies response
replies PackageName
name Request
request response -> IO ResponseReceived
respond = do
    (RequestCtx -> Maybe PublishDeps) -> Handler (Maybe PublishDeps)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (MountBinding -> Maybe PublishDeps
bindingPublishDeps (MountBinding -> Maybe PublishDeps)
-> (RequestCtx -> MountBinding) -> RequestCtx -> Maybe PublishDeps
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestCtx -> MountBinding
ctxMount) Handler (Maybe PublishDeps)
-> (Maybe PublishDeps -> Handler ResponseReceived)
-> Handler ResponseReceived
forall a b. Handler a -> (a -> Handler b) -> Handler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe PublishDeps
Nothing -> IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (response -> IO ResponseReceived
respond (PublishReplies response -> response
forall response. PublishReplies response -> response
publishDisabled PublishReplies response
replies))
        Just PublishDeps
deps -> PublishReplies response
-> PublishDeps
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
PublishReplies response
-> PublishDeps
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
publishWithDeps PublishReplies response
replies PublishDeps
deps PackageName
name Request
request response -> IO ResponseReceived
respond

-- Serve a publish once the mount's publication target is known: the edge gate, the
-- anti-shadowing scope guard, then the body-name agreement check (all before any write),
-- then the relay to the publication target with the publisher's forwarded credential.
publishWithDeps ::
    PublishReplies response ->
    PublishDeps ->
    PackageName ->
    Request ->
    (response -> IO ResponseReceived) ->
    Handler ResponseReceived
publishWithDeps :: forall response.
PublishReplies response
-> PublishDeps
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
publishWithDeps PublishReplies response
replies PublishDeps
deps PackageName
name Request
request response -> IO ResponseReceived
respond
    | Bool -> Bool
not (Maybe Secret -> Maybe Secret -> Bool
edgeTokenMatches (PublishDeps -> Maybe Secret
pubInboundToken PublishDeps
deps) Maybe Secret
clientToken) =
        IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (response -> IO ResponseReceived
respond (PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
forall response.
PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
publishError PublishReplies response
replies (Int -> ByteString -> Status
mkStatus Int
401 ByteString
"Unauthorized") [] Text
"authentication required"))
    | Bool -> Bool
not ([Scope] -> PackageName -> Bool
inPublishScope (PublishDeps -> [Scope]
pubScopes PublishDeps
deps) PackageName
name) =
        IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (response -> IO ResponseReceived
respond (PublishReplies response -> PublishDeps -> PackageName -> response
forall response.
PublishReplies response -> PublishDeps -> PackageName -> response
outOfScope PublishReplies response
replies PublishDeps
deps PackageName
name))
    | Bool
overDeclaredCap =
        -- A declared Content-Length already over the cap fails closed before a byte is
        -- read (no reservation, no relay). A chunked body carries no length to judge up
        -- front, so its cap is enforced by the counted read below instead.
        IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (response -> IO ResponseReceived
respond (PublishReplies response -> PublishDeps -> response
forall response. PublishReplies response -> PublishDeps -> response
publishTooLarge PublishReplies response
replies PublishDeps
deps))
    | Bool
otherwise = do
        rt <- (RequestCtx -> ServeRuntime) -> Handler ServeRuntime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestCtx -> ServeRuntime
ctxRuntime
        -- The whole buffered-body residency -- read, name check, relay -- runs
        -- inside the aggregate byte-admission, acquired only after the edge gate
        -- and the scope guard admitted the request, so a refused publish reserves
        -- nothing. The weight is the declared Content-Length; a chunked body
        -- declares nothing and reserves the per-request cap pessimistically, so
        -- the reservation always covers the bounded read's ceiling. Exhaustion
        -- sheds with the read path's vocabulary: a brief in-process wait, then a
        -- 503 with the same Retry-After hint.
        outcome <- withByteAdmission (srMetrics rt) (pubBodyBudget deps) bodyWeight $ do
            -- Read the body chunk-by-chunk through 'boundedRead', bounded at the
            -- per-request cap and returning the breach as a __value__: a chunked body
            -- has no declared length, so this counted read is what caps it -- a
            -- fail-closed 413, never a truncated body, never a throw across the
            -- perimeter. Read only after the scope guard admitted the name, so a
            -- refused publish never even buffers its (large, base64-tarball) body.
            liftIO (boundedRead requestBodyLimits (getRequestBodyChunk request)) >>= \case
                -- 'boundedRead' reports only 'BodyTooLarge'; any breach of the request cap is the 413.
                Left LimitError
_ -> response -> Handler response
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PublishReplies response -> PublishDeps -> response
forall response. PublishReplies response -> PublishDeps -> response
publishTooLarge PublishReplies response
replies PublishDeps
deps)
                -- The body-name agreement leg of the anti-shadowing guard (issue #391): the scope
                -- guard authorised the URL-path name, but the publish document carries its own
                -- declared identity, so a crafted body could otherwise write a name the guard never
                -- saw. Refuse -- before the relay -- any present declared name that disagrees with the
                -- URL-path name, so the identity authorised is provably the identity written.
                Right ByteString
body -> case (LByteString -> [Text])
-> (Text -> Maybe PackageName)
-> PackageName
-> LByteString
-> Maybe Text
bodyNameDisagreement (PublishDeps -> LByteString -> [Text]
pubDeclaredNames PublishDeps
deps) (PublishDeps -> Text -> Maybe PackageName
pubCanonicaliseName PublishDeps
deps) PackageName
name (ByteString -> LByteString
LBS.fromStrict ByteString
body) of
                    Just Text
declared -> response -> Handler response
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PublishReplies response
-> PublishDeps -> PackageName -> Text -> response
forall response.
PublishReplies response
-> PublishDeps -> PackageName -> Text -> response
bodyNameMismatch PublishReplies response
replies PublishDeps
deps PackageName
name Text
declared)
                    -- The relay reports its failures as the typed 'PublishRelayFault'
                    -- value, so the render below is a total match -- nothing caught, and
                    -- residue is the perimeter's. 'boundedRead' returns the body strict,
                    -- which the publish builder puts on the wire as a strict 'RequestBodyBS'.
                    Maybe Text
Nothing ->
                        PublishReplies response
-> PublishDeps
-> Either PublishRelayFault PublishRelayResponse
-> response
forall response.
PublishReplies response
-> PublishDeps
-> Either PublishRelayFault PublishRelayResponse
-> response
renderRelay PublishReplies response
replies PublishDeps
deps
                            (Either PublishRelayFault PublishRelayResponse -> response)
-> Handler (Either PublishRelayFault PublishRelayResponse)
-> Handler response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either PublishRelayFault PublishRelayResponse)
-> Handler (Either PublishRelayFault PublishRelayResponse)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (PublishDeps
-> Limits
-> Manager
-> Text
-> Maybe Secret
-> PackageName
-> ByteString
-> IO (Either PublishRelayFault PublishRelayResponse)
pubRelayPublish PublishDeps
deps (PublishDeps -> Limits
pubLimits PublishDeps
deps) (ServeRuntime -> Manager
srPrivateManager ServeRuntime
rt) (PublishDeps -> Text
pubTargetUrl PublishDeps
deps) (Maybe Secret
clientToken Maybe Secret -> Maybe Secret -> Maybe Secret
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PublishDeps -> Maybe Secret
pubStaticToken PublishDeps
deps) PackageName
name ByteString
body)
        liftIO (respond (fromMaybe (bodyBudgetShed replies deps) outcome))
  where
    -- The publisher's bearer, scanned out of the headers once: the edge gate
    -- compares it and the relay forwards it (falling back to the static token).
    clientToken :: Maybe Secret
clientToken = Request -> Maybe Secret
forwardedToken Request
request

    -- The per-request body cap as a 'boundedRead' bound. 'boundedRead' consults only
    -- 'maxBodyBytes', so the response budget's other 'Limits' fields are immaterial
    -- here; this keeps the request cap named in one place ('pubMaxRequestBytes').
    requestBodyLimits :: Limits
requestBodyLimits = (PublishDeps -> Limits
pubLimits PublishDeps
deps){maxBodyBytes = pubMaxRequestBytes deps}

    -- Whether the request declares a Content-Length already over the per-request cap.
    overDeclaredCap :: Bool
overDeclaredCap = case Request -> RequestBodyLength
requestBodyLength Request
request of
        KnownLength Word64
n -> Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PublishDeps -> Int
pubMaxRequestBytes PublishDeps
deps)
        RequestBodyLength
ChunkedBody -> Bool
False

    bodyWeight :: Int
bodyWeight = case Request -> RequestBodyLength
requestBodyLength Request
request of
        KnownLength Word64
n -> Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n
        RequestBodyLength
ChunkedBody -> PublishDeps -> Int
pubMaxRequestBytes PublishDeps
deps

{- Whether a package name falls within the configured publish-scope allow-list -- the
anti-shadowing guard. A __scoped__ name is admitted iff its scope is one of the
configured scopes; an __unscoped__ name is never in any scope, so it is refused (the
MVP allow-list is scope-based, e.g. @\@acme@). The scope equality is exact, so
@\@acme-evil@ does not match an @\@acme@ allow-list entry. -}
inPublishScope :: [Scope] -> PackageName -> Bool
inPublishScope :: [Scope] -> PackageName -> Bool
inPublishScope [Scope]
scopes PackageName
name = case PackageName -> Maybe Scope
pkgNamespace PackageName
name of
    Just Scope
scope -> Scope
scope Scope -> [Scope] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Scope]
scopes
    Maybe Scope
Nothing -> Bool
False

{- Render the relay outcome: the publication target's own status and body forwarded to
the client on success (so the publisher sees the registry's real answer -- a success
shape, a @409@, a @403@ the registry's own authorisation produced); a @502@ when the
target's answer never arrived whole (a transport fault, or a response past the bound);
a @500@ when its URL is unformable (misconfiguration). -}
renderRelay ::
    PublishReplies response ->
    PublishDeps ->
    Either PublishRelayFault PublishRelayResponse ->
    response
renderRelay :: forall response.
PublishReplies response
-> PublishDeps
-> Either PublishRelayFault PublishRelayResponse
-> response
renderRelay PublishReplies response
replies PublishDeps
deps = \case
    Right (PublishRelayResponse Int
code LByteString
relayed) ->
        PublishReplies response
-> Status -> ResponseHeaders -> LByteString -> response
forall response.
PublishReplies response
-> Status -> ResponseHeaders -> LByteString -> response
publishRelayed PublishReplies response
replies (Int -> ByteString -> Status
mkStatus Int
code ByteString
"") [] LByteString
relayed
    Left (RelayUrlUnformable UrlFormationError
_urlErr) ->
        PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
forall response.
PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
publishError PublishReplies response
replies Status
status500 [] (Maybe HelpMessage -> Text -> Text
appendHelp (PublishDeps -> Maybe HelpMessage
pubHelp PublishDeps
deps) Text
"the publication target URL is misconfigured")
    Left (RelayTransport TransportFault
_fault) ->
        PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
forall response.
PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
publishError PublishReplies response
replies Status
status502 [] (Maybe HelpMessage -> Text -> Text
appendHelp (PublishDeps -> Maybe HelpMessage
pubHelp PublishDeps
deps) Text
"the publication target could not be reached")
    Left (RelayBoundExceeded LimitError
_limit) ->
        PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
forall response.
PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
publishError PublishReplies response
replies Status
status502 [] (Maybe HelpMessage -> Text -> Text
appendHelp (PublishDeps -> Maybe HelpMessage
pubHelp PublishDeps
deps) Text
"the publication target could not be reached")

-- A @503@ for a publish shed at the aggregate body-byte budget: server capacity,
-- not client rate (so not a @429@), with the same brief-wait-then-shed timing and
-- @Retry-After@ hint as the read path's admission.
bodyBudgetShed :: PublishReplies response -> PublishDeps -> response
bodyBudgetShed :: forall response. PublishReplies response -> PublishDeps -> response
bodyBudgetShed PublishReplies response
replies PublishDeps
deps =
    PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
forall response.
PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
publishError PublishReplies response
replies Status
shedStatus [Header
shedRetryAfter] (Maybe HelpMessage -> Text -> Text
appendHelp (PublishDeps -> Maybe HelpMessage
pubHelp PublishDeps
deps) Text
"the server is at its publish-body capacity; retry shortly")

-- A @413@ for a publish whose body exceeds the per-request size cap
-- ('pubMaxRequestBytes', the client→proxy request-body limit): a declared
-- Content-Length over the cap, or a chunked body whose counted read crossed it.
-- Rendered through the route's own error contract, before any upstream write.
publishTooLarge :: PublishReplies response -> PublishDeps -> response
publishTooLarge :: forall response. PublishReplies response -> PublishDeps -> response
publishTooLarge PublishReplies response
replies PublishDeps
deps =
    PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
forall response.
PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
publishError PublishReplies response
replies Status
status413 [] (Maybe HelpMessage -> Text -> Text
appendHelp (PublishDeps -> Maybe HelpMessage
pubHelp PublishDeps
deps) Text
"the publish body exceeds the maximum accepted request size")

-- A @405@ for a publish on a mount with no publication target configured: the
-- opt-in path is off, so a @PUT \/{pkg}@ is not an allowed method here. The @Allow@
-- header advertises the read methods the package route does serve.
publishDisabled :: PublishReplies response -> response
publishDisabled :: forall response. PublishReplies response -> response
publishDisabled PublishReplies response
replies =
    PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
forall response.
PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
publishError PublishReplies response
replies Status
status405 [(HeaderName
"Allow", ByteString
"GET, HEAD")] Text
"publishing is not enabled on this proxy (no publication target is configured)"

-- A @403@ for a publish whose name is outside the configured publish-scope
-- allow-list -- the anti-shadowing guard, refused before any upstream write.
outOfScope :: PublishReplies response -> PublishDeps -> PackageName -> response
outOfScope :: forall response.
PublishReplies response -> PublishDeps -> PackageName -> response
outOfScope PublishReplies response
replies PublishDeps
deps PackageName
name =
    PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
forall response.
PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
publishError PublishReplies response
replies Status
status403 [] (Maybe HelpMessage -> Text -> Text
appendHelp (PublishDeps -> Maybe HelpMessage
pubHelp PublishDeps
deps) Text
message)
  where
    message :: Text
    message :: Text
message =
        Text
"refusing to publish '"
            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
"': its name is outside the configured publish-scope allow-list (the anti-shadowing guard against publishing a name that shadows a public package)"

-- A @403@ for a publish whose document body declares a package name (read by the
-- ecosystem's own injected extractor, 'pubDeclaredNames') that disagrees with the
-- scope-guarded URL-path name. The body-name agreement leg of the anti-shadowing guard
-- (issue #391), refused before any upstream write so the identity the guard authorises
-- is the identity written.
bodyNameMismatch :: PublishReplies response -> PublishDeps -> PackageName -> Text -> response
bodyNameMismatch :: forall response.
PublishReplies response
-> PublishDeps -> PackageName -> Text -> response
bodyNameMismatch PublishReplies response
replies PublishDeps
deps PackageName
name Text
declared =
    PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
forall response.
PublishReplies response
-> Status -> ResponseHeaders -> Text -> response
publishError PublishReplies response
replies Status
status403 [] (Maybe HelpMessage -> Text -> Text
appendHelp (PublishDeps -> Maybe HelpMessage
pubHelp PublishDeps
deps) Text
message)
  where
    message :: Text
    message :: Text
message =
        Text
"refusing to publish '"
            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
"': the document body declares the name '"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
declared
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"', which disagrees with the URL-path package name the scope guard authorised (the anti-shadowing guard against publishing a name the allow-list never saw)"

{- The first declared body name that disagrees with the URL-path name, or 'Nothing'
when the body declares no disagreeing name. The publish document carries its own
identity, so a relay that keyed the write off the body could otherwise write a name the
scope guard never authorised. The ecosystem's own 'pubDeclaredNames' extractor reads
each present declared name from the raw body (the publish-document schema is the
adapter's knowledge, not this neutral pipeline's), and each is canonicalised the same
way the route builds its 'PackageName' and compared by 'PackageName' equality
(ecosystem-aware, so an encoding variant of the same name cannot disagree silently). A
present name that does not equal the URL-path name is a disagreement. An __absent__
name is not a claim, so it is not a disagreement (a legitimate client always sends
matching names); a body the extractor reads no name from raises none, leaving the relay
to meet the target's own validation. -}
bodyNameDisagreement :: (LByteString -> [Text]) -> (Text -> Maybe PackageName) -> PackageName -> LByteString -> Maybe Text
bodyNameDisagreement :: (LByteString -> [Text])
-> (Text -> Maybe PackageName)
-> PackageName
-> LByteString
-> Maybe Text
bodyNameDisagreement LByteString -> [Text]
declaredNames Text -> Maybe PackageName
canonicalise PackageName
name LByteString
body =
    (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Text -> Bool
disagrees (LByteString -> [Text]
declaredNames LByteString
body)
  where
    disagrees :: Text -> Bool
    disagrees :: Text -> Bool
disagrees Text
declared = case Text -> Maybe PackageName
canonicalise Text
declared of
        Just PackageName
declaredName -> PackageName
declaredName PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
/= PackageName
name
        Maybe PackageName
Nothing -> Bool
True