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

{- | The first-party publish route, guarded before any upstream write.
Credential selection follows the authenticated edge mode. Body limits and name agreement
bound the request before the adapter relays it to the publication target.
-}
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, status401, status403, status405, status413, status500, status502)
import Network.Wai (Request, RequestBodyLength (ChunkedBody, KnownLength), ResponseReceived, getRequestBodyChunk, requestBodyLength)

import Ecluse.Core.Credential (ClientCredential, bareCredential)
import Ecluse.Core.Package (PackageName, renderPackageName)
import Ecluse.Core.Registry (FetchFault (FetchBoundExceeded, FetchTransport, FetchUrlUnformable), PublishRelayResponse (PublishRelayResponse))
import Ecluse.Core.Registry.Adapter.Capability (AdapterPublish (publishDeclaredNames, publishRelay))
import Ecluse.Core.Registry.Exchange (withinServeCap)
import Ecluse.Core.Registry.Origin (OriginClient, originClient)
import Ecluse.Core.Security (BodyLimit (PublishRequestBodyLimit), Limits (maxPublishRequestBytes, progressFloor), boundedRead)
import Ecluse.Core.Server.Admission.Bytes (withByteAdmission)
import Ecluse.Core.Server.Context (
    Handler,
    MountBinding (bindingPublishDeps),
    PublishDeps (..),
    ServeRuntime (..),
    ctxMount,
    ctxRuntime,
 )
import Ecluse.Core.Server.Pipeline.Shared
import Ecluse.Core.Server.Response (appendHelp)

-- | Route-owned replies, including the publication target's unrestricted status codes.
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.
    }

-- | Relay a configured first-party publish after authentication and body guards.
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
    mount <- (RequestCtx -> MountBinding) -> Handler MountBinding
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestCtx -> MountBinding
ctxMount
    case bindingPublishDeps mount of
        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
-> Maybe ClientCredential
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
PublishReplies response
-> PublishDeps
-> Maybe ClientCredential
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
publishWithDeps PublishReplies response
replies PublishDeps
deps (MountBinding -> Request -> Maybe ClientCredential
forwardedCredential MountBinding
mount Request
request) PackageName
name Request
request response -> IO ResponseReceived
respond

publishWithDeps ::
    PublishReplies response ->
    PublishDeps ->
    Maybe ClientCredential ->
    PackageName ->
    Request ->
    (response -> IO ResponseReceived) ->
    Handler ResponseReceived
publishWithDeps :: forall response.
PublishReplies response
-> PublishDeps
-> Maybe ClientCredential
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
publishWithDeps PublishReplies response
replies PublishDeps
deps Maybe ClientCredential
clientToken PackageName
name Request
request response -> IO ResponseReceived
respond
    | Bool -> Bool
not (Maybe Secret -> Maybe ClientCredential -> Bool
edgeTokenMatches (PublishDeps -> Maybe Secret
pubInboundToken PublishDeps
deps) Maybe ClientCredential
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 Status
status401 [] Text
unauthorisedMessage))
    | Bool -> Bool
not (PublishDeps -> PackageName -> Bool
pubAllowed 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 =
        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
        outcome <-
            withByteAdmission (srMetrics rt) (pubBodyBudget deps) bodyWeight $
                liftIO (readAndRelay replies deps (publicationTarget deps rt clientToken) name request)
        liftIO (respond (fromMaybe (bodyBudgetShed replies deps) outcome))
  where
    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 (Limits -> Int
maxPublishRequestBytes (PublishDeps -> Limits
pubLimits 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 -> Limits -> Int
maxPublishRequestBytes (PublishDeps -> Limits
pubLimits PublishDeps
deps)

{- Read the bounded body, check the name it declares, then relay, in that order. This runs
inside the byte-admission bracket, so the reserved weight always covers the bytes buffered. -}
readAndRelay ::
    PublishReplies response ->
    PublishDeps ->
    OriginClient ->
    PackageName ->
    Request ->
    IO response
readAndRelay :: forall response.
PublishReplies response
-> PublishDeps
-> OriginClient
-> PackageName
-> Request
-> IO response
readAndRelay PublishReplies response
replies PublishDeps
deps OriginClient
target PackageName
name Request
request =
    BodyLimit
-> IO ByteString -> IO (Either LimitError (Int, ByteString))
forall (m :: * -> *).
Monad m =>
BodyLimit
-> m ByteString -> m (Either LimitError (Int, ByteString))
boundedRead (Int -> BodyLimit
PublishRequestBodyLimit (Limits -> Int
maxPublishRequestBytes (PublishDeps -> Limits
pubLimits PublishDeps
deps))) (Request -> IO ByteString
getRequestBodyChunk Request
request) IO (Either LimitError (Int, ByteString))
-> (Either LimitError (Int, ByteString) -> IO response)
-> IO response
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left LimitError
_ -> response -> IO response
forall a. a -> IO 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)
        Right (Int
_, ByteString
body) -> case (LByteString -> [Text])
-> (Text -> Maybe PackageName)
-> PackageName
-> LByteString
-> Maybe Text
bodyNameDisagreement (AdapterPublish -> LByteString -> [Text]
publishDeclaredNames (PublishDeps -> AdapterPublish
pubAdapter PublishDeps
deps)) (PublishDeps -> Text -> Maybe PackageName
pubProjectName PublishDeps
deps) PackageName
name (ByteString -> LByteString
LBS.fromStrict ByteString
body) of
            Just Text
declared -> response -> IO response
forall a. a -> IO 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)
            Maybe Text
Nothing -> PublishReplies response
-> PublishDeps
-> Either FetchFault PublishRelayResponse
-> response
forall response.
PublishReplies response
-> PublishDeps
-> Either FetchFault PublishRelayResponse
-> response
renderRelay PublishReplies response
replies PublishDeps
deps (Either FetchFault PublishRelayResponse -> response)
-> IO (Either FetchFault PublishRelayResponse) -> IO response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProgressFloor
-> (FetchFault -> FetchFault)
-> IO (Either FetchFault PublishRelayResponse)
-> IO (Either FetchFault PublishRelayResponse)
forall e a.
ProgressFloor
-> (FetchFault -> e) -> IO (Either e a) -> IO (Either e a)
withinServeCap (Limits -> ProgressFloor
progressFloor (PublishDeps -> Limits
pubLimits PublishDeps
deps)) FetchFault -> FetchFault
forall a. a -> a
id (AdapterPublish
-> OriginClient
-> PackageName
-> ByteString
-> IO (Either FetchFault PublishRelayResponse)
publishRelay (PublishDeps -> AdapterPublish
pubAdapter PublishDeps
deps) OriginClient
target PackageName
name ByteString
body)

publicationTarget :: PublishDeps -> ServeRuntime -> Maybe ClientCredential -> OriginClient
publicationTarget :: PublishDeps
-> ServeRuntime -> Maybe ClientCredential -> OriginClient
publicationTarget PublishDeps
deps ServeRuntime
rt Maybe ClientCredential
clientToken =
    Limits
-> Manager -> RegistryUrl -> Maybe ClientCredential -> OriginClient
originClient
        (PublishDeps -> Limits
pubLimits PublishDeps
deps)
        (ServeRuntime -> Manager
srPrivateManager ServeRuntime
rt)
        (PublishDeps -> RegistryUrl
pubTargetUrl PublishDeps
deps)
        (PublishDeps -> Maybe ClientCredential -> Maybe ClientCredential
publicationCredential PublishDeps
deps Maybe ClientCredential
clientToken)

-- A configured static token replaces the caller's own, but only on an authenticated edge, so
-- an open edge never mints it.
publicationCredential :: PublishDeps -> Maybe ClientCredential -> Maybe ClientCredential
publicationCredential :: PublishDeps -> Maybe ClientCredential -> Maybe ClientCredential
publicationCredential PublishDeps
deps Maybe ClientCredential
clientToken = case (PublishDeps -> Maybe Secret
pubInboundToken PublishDeps
deps, PublishDeps -> Maybe Secret
pubStaticToken PublishDeps
deps) of
    (Just Secret
_, Just Secret
staticToken) -> ClientCredential -> Maybe ClientCredential
forall a. a -> Maybe a
Just (Secret -> ClientCredential
bareCredential Secret
staticToken)
    (Maybe Secret, Maybe Secret)
_ -> Maybe ClientCredential
clientToken

renderRelay ::
    PublishReplies response ->
    PublishDeps ->
    Either FetchFault PublishRelayResponse ->
    response
renderRelay :: forall response.
PublishReplies response
-> PublishDeps
-> Either FetchFault 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
    -- An unformable target URL is this proxy's own misconfiguration, so it answers 500. The
    -- other two are the target's failure to answer, so they answer 502.
    Left (FetchUrlUnformable 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 (FetchTransport 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 (FetchBoundExceeded 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@. Same wait-then-shed timing and @Retry-After@ hint as the read path.
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")

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 @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
message
  where
    -- The remediation stays ecosystem-neutral, because this pipeline serves every
    -- ecosystem: it names no client's own commands or configuration keys.
    message :: Text
    message :: Text
message =
        Text
"publishing is not enabled on this proxy (no publication target is configured); \
        \publish directly to the registry you intend to publish to"

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 first-party namespaces this deployment declares (the anti-shadowing guard against publishing a name that shadows a public package)"

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 requested package name the first-party guard authorised (the anti-shadowing guard against publishing a name the guard never saw)"

-- A body-driven target must not write a name the URL-path guard never authorised.
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