{- | 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,
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 (
    -- * The first-party publish handler
    servePublish,
) where

import Data.Aeson (Value (String))
import Data.Aeson qualified as Aeson
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString.Lazy qualified as LBS

import Lens.Micro ((^?))
import Lens.Micro.Aeson (key, _Object)
import Network.HTTP.Types (mkStatus, status403, status405, status500, status502)
import Network.Wai (Request, Response, ResponseReceived, consumeRequestBodyStrict)
import UnliftIO.Exception (tryAny)

import Ecluse.Core.Package (
    PackageName,
    Scope,
    pkgNamespace,
    renderPackageName,
 )
import Ecluse.Core.Registry (PublishRelayResponse (PublishRelayResponse), UrlFormationError)
import Ecluse.Core.Server.Context (
    Handler,
    MountBinding (bindingPublishDeps, bindingRenderer),
    PublishDeps (..),
    ServeRuntime (srPrivateManager),
    ctxMount,
    ctxRuntime,
 )
import Ecluse.Core.Server.Pipeline.Shared

import Ecluse.Core.Server.Response (
    MountRenderer,
    renderError,
 )

servePublish ::
    PackageName ->
    Request ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
servePublish :: PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
servePublish PackageName
name Request
request Response -> IO ResponseReceived
respond = do
    renderer <- (RequestCtx -> MountRenderer) -> Handler MountRenderer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (MountBinding -> MountRenderer
bindingRenderer (MountBinding -> MountRenderer)
-> (RequestCtx -> MountBinding) -> RequestCtx -> MountRenderer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestCtx -> MountBinding
ctxMount)
    asks (bindingPublishDeps . ctxMount) >>= \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 (MountRenderer -> Response
publishDisabled MountRenderer
renderer))
        Just PublishDeps
deps -> MountRenderer
-> PublishDeps
-> PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
publishWithDeps MountRenderer
renderer 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 ::
    MountRenderer ->
    PublishDeps ->
    PackageName ->
    Request ->
    (Response -> IO ResponseReceived) ->
    Handler ResponseReceived
publishWithDeps :: MountRenderer
-> PublishDeps
-> PackageName
-> Request
-> (Response -> IO ResponseReceived)
-> Handler ResponseReceived
publishWithDeps MountRenderer
renderer 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 (MountRenderer -> Response
edgeUnauthorised MountRenderer
renderer))
    | 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 (MountRenderer -> PublishDeps -> PackageName -> Response
outOfScope MountRenderer
renderer PublishDeps
deps PackageName
name))
    | Bool
otherwise = do
        rt <- (RequestCtx -> ServeRuntime) -> Handler ServeRuntime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestCtx -> ServeRuntime
ctxRuntime
        -- The body is bounded by the client→proxy request-size cap (the size-limit
        -- middleware), read here only after the scope guard has admitted the name, so a
        -- refused publish never even buffers its (potentially large, base64-tarball)
        -- body.
        body <- liftIO (consumeRequestBodyStrict request)
        -- 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.
        case bodyNameDisagreement (pubCanonicaliseName deps) name body of
            Just Text
declared -> IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Response -> IO ResponseReceived
respond (MountRenderer -> PublishDeps -> PackageName -> Text -> Response
bodyNameMismatch MountRenderer
renderer PublishDeps
deps PackageName
name Text
declared))
            -- @consumeRequestBodyStrict@ reads the whole body but returns it lazy; the
            -- publish builder ('relayPublishDocument') puts it on the wire as a strict
            -- @RequestBodyBS@, so materialise it strict here. The body is already bounded by
            -- the client→proxy request-size cap.
            Maybe Text
Nothing -> do
                outcome <- Handler (Either UrlFormationError PublishRelayResponse)
-> Handler
     (Either
        SomeException (Either UrlFormationError PublishRelayResponse))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (IO (Either UrlFormationError PublishRelayResponse)
-> Handler (Either UrlFormationError 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 UrlFormationError 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 -> ByteString
LBS.toStrict ByteString
body)))
                liftIO (respond (renderRelay renderer 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

{- 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 could not be reached; a @500@ when its URL is unformable (misconfiguration). -}
renderRelay ::
    MountRenderer ->
    PublishDeps ->
    Either SomeException (Either UrlFormationError PublishRelayResponse) ->
    Response
renderRelay :: MountRenderer
-> PublishDeps
-> Either
     SomeException (Either UrlFormationError PublishRelayResponse)
-> Response
renderRelay MountRenderer
renderer PublishDeps
deps = \case
    Right (Right (PublishRelayResponse Int
code ByteString
relayed)) ->
        Status -> ResponseHeaders -> ByteString -> Response
jsonResponse (Int -> ByteString -> Status
mkStatus Int
code ByteString
"") [] ByteString
relayed
    Right (Left UrlFormationError
_urlErr) ->
        Status -> ResponseHeaders -> RenderedBody -> Response
renderedResponse Status
status500 [] (MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer (PublishDeps -> Maybe HelpMessage
pubHelp PublishDeps
deps) Text
"the publication target URL is misconfigured")
    Left SomeException
_exc ->
        Status -> ResponseHeaders -> RenderedBody -> Response
renderedResponse Status
status502 [] (MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer (PublishDeps -> Maybe HelpMessage
pubHelp PublishDeps
deps) Text
"the publication target could not be reached")

-- 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 :: MountRenderer -> Response
publishDisabled :: MountRenderer -> Response
publishDisabled MountRenderer
renderer =
    Status -> ResponseHeaders -> RenderedBody -> Response
renderedResponse Status
status405 [(HeaderName
"Allow", ByteString
"GET, HEAD")] (MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer Maybe HelpMessage
forall a. Maybe a
Nothing 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 :: MountRenderer -> PublishDeps -> PackageName -> Response
outOfScope :: MountRenderer -> PublishDeps -> PackageName -> Response
outOfScope MountRenderer
renderer PublishDeps
deps PackageName
name =
    Status -> ResponseHeaders -> RenderedBody -> Response
renderedResponse Status
status403 [] (MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer (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 -- its @_id@,
-- top-level @name@, or a @versions[].name@ -- 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 :: MountRenderer -> PublishDeps -> PackageName -> Text -> Response
bodyNameMismatch :: MountRenderer -> PublishDeps -> PackageName -> Text -> Response
bodyNameMismatch MountRenderer
renderer PublishDeps
deps PackageName
name Text
declared =
    Status -> ResponseHeaders -> RenderedBody -> Response
renderedResponse Status
status403 [] (MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer (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 -- a top-level @_id@ and @name@, and a @name@ per entry in @versions@ -- so a
relay that keyed the write off the body could otherwise write a name the scope guard
never authorised. Each __present__ declared name is canonicalised the same way the
route builds its 'PackageName' ('projectName') 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. Only the names
are read -- the base64 @_attachments@ are never decoded. An __absent__ name is not a
claim, so it is not a disagreement (a legitimate npm client always sends matching
names); a body that does not decode to a JSON object likewise declares no readable
name and raises none, leaving the relay to meet the target's own validation. -}
bodyNameDisagreement :: (Text -> Maybe PackageName) -> PackageName -> LByteString -> Maybe Text
bodyNameDisagreement :: (Text -> Maybe PackageName)
-> PackageName -> ByteString -> Maybe Text
bodyNameDisagreement Text -> Maybe PackageName
canonicalise PackageName
name ByteString
body =
    case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
body of
        Maybe Value
Nothing -> Maybe Text
forall a. Maybe a
Nothing
        Just Value
document -> (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Text -> Bool
disagrees (Value -> [Text]
declaredNames Value
document)
  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

-- Every package-name string a publish document declares as its own identity: the
-- top-level @_id@ and @name@, and each @versions.<v>.name@. Only string-valued name
-- slots are read (a non-string slot is no name claim); the base64 @_attachments@ are
-- never touched.
declaredNames :: Value -> [Text]
declaredNames :: Value -> [Text]
declaredNames Value
document =
    [ Text
declared
    | Maybe Value
slot <-
        [Value
document Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"_id", Value
document Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"name"]
            [Maybe Value] -> [Maybe Value] -> [Maybe Value]
forall a. Semigroup a => a -> a -> a
<> [ Value
versionDoc Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"name"
               | KeyMap Value
versions <- Maybe (KeyMap Value) -> [KeyMap Value]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Value
document Value
-> Getting (First (KeyMap Value)) Value (KeyMap Value)
-> Maybe (KeyMap Value)
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"versions" ((Value -> Const (First (KeyMap Value)) Value)
 -> Value -> Const (First (KeyMap Value)) Value)
-> Getting (First (KeyMap Value)) Value (KeyMap Value)
-> Getting (First (KeyMap Value)) Value (KeyMap Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First (KeyMap Value)) Value (KeyMap Value)
forall t. AsValue t => Traversal' t (KeyMap Value)
Traversal' Value (KeyMap Value)
_Object)
               , Value
versionDoc <- KeyMap Value -> [Value]
forall v. KeyMap v -> [v]
KeyMap.elems KeyMap Value
versions
               ]
    , Just (String Text
declared) <- [Maybe Value
slot]
    ]