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

{- | The npm publish-document schema: the mirror-write side (document assembly,
request shaping, and the codec that carries them into the shared publish transport)
and the read side ('declaredNames', the identity names the ecosystem-neutral publish
pipeline's anti-shadowing guard reads from a first-party publish body).

Everything here is pure. 'npmPublishCodec' is npm's
'Ecluse.Core.Registry.Publish.PublishCodec': the composition root marries it to
the shared transport ('Ecluse.Core.Registry.Publish.newMirrorPublish'), which
executes what this module forms. The first-party publish relay (a different
concern: a client's own document forwarded verbatim) lives in
"Ecluse.Core.Registry.Npm".
-}
module Ecluse.Core.Registry.Npm.Publish (
    npmPublishCodec,
    publishRequest,
    npmPublishDocument,
    declaredNames,
) where

import Data.Aeson (Value (String), object, (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteArray.Encoding (Base (Base64), convertToBase)
import Data.ByteString qualified as BS

import Lens.Micro ((^?))
import Lens.Micro.Aeson (key, _Object)
import Network.HTTP.Client (Request (method, requestBody, requestHeaders), RequestBody (RequestBodyBS))
import Network.HTTP.Types.Header (hAccept, hContentType)

import Ecluse.Core.Credential (Secret)
import Ecluse.Core.Package (HashAlg (SHA1, SRI), PackageName, renderPackageName)
import Ecluse.Core.Registry (
    MirrorArtifact (maFilename),
    PublishError (PublishError),
    PublishFault (PublishRejected),
    UrlFormationError,
    firstHashValue,
 )
import Ecluse.Core.Registry.Npm.Project qualified as Project
import Ecluse.Core.Registry.Npm.Request (MetadataForm (Abbreviated), metadataRequest, noValidators, packageUrl, parseRequestEither, withToken)
import Ecluse.Core.Registry.Publish (PublishCodec (..))
import Ecluse.Core.Version (Version, renderVersion)

{- | npm's mirror-write protocol codec: the presence probe reads the abbreviated
packument and projects its version list; the publish assembles the
packument-fragment @PUT@ ('npmPublishDocument' under 'publishRequest'), with the
@dist@ digests picked from the re-admitted artifact's verified set; and a @409@
answer is idempotent success (versions are immutable, so an already-present
version is the write's goal already met).
-}
npmPublishCodec :: PublishCodec
npmPublishCodec :: PublishCodec
npmPublishCodec =
    PublishCodec
        { pcProbeRequest :: Text
-> Maybe Secret -> PackageName -> Either UrlFormationError Request
pcProbeRequest = \Text
targetUrl Maybe Secret
token -> Text
-> Maybe Secret
-> MetadataForm
-> Validators
-> PackageName
-> Either UrlFormationError Request
metadataRequest Text
targetUrl Maybe Secret
token MetadataForm
Abbreviated Validators
noValidators
        , pcParseVersionList :: RegistryResponse -> Either ParseError [Version]
pcParseVersionList = RegistryResponse -> Either ParseError [Version]
Project.parseVersionList
        , pcPublishRequest :: Text
-> Maybe Secret
-> PackageName
-> Version
-> MirrorArtifact
-> ByteString
-> Either UrlFormationError Request
pcPublishRequest = \Text
targetUrl Maybe Secret
token PackageName
name Version
version MirrorArtifact
artifact ByteString
bytes ->
            Text
-> Maybe Secret
-> PackageName
-> ByteString
-> Either UrlFormationError Request
publishRequest
                Text
targetUrl
                Maybe Secret
token
                PackageName
name
                (PackageName
-> Version
-> Text
-> Maybe Text
-> Maybe Text
-> ByteString
-> ByteString
npmPublishDocument PackageName
name Version
version (MirrorArtifact -> Text
maFilename MirrorArtifact
artifact) (MirrorArtifact -> Maybe Text
sriOf MirrorArtifact
artifact) (MirrorArtifact -> Maybe Text
sha1Of MirrorArtifact
artifact) ByteString
bytes)
        , pcPublishOutcome :: Int -> Either PublishFault ()
pcPublishOutcome = Int -> Either PublishFault ()
classifyPublish
        }

{- Map a publish response status onto success or a 'PublishFault'. A 2xx or a
@409@ (already present, immutable) is success; anything else is a retryable
'PublishRejected' naming the status the job saw.
-}
classifyPublish :: Int -> Either PublishFault ()
classifyPublish :: Int -> Either PublishFault ()
classifyPublish Int
code
    | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300 = () -> Either PublishFault ()
forall a b. b -> Either a b
Right ()
    | Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
409 = () -> Either PublishFault ()
forall a b. b -> Either a b
Right () -- version already present; immutable, so success-equivalent
    | Bool
otherwise =
        PublishFault -> Either PublishFault ()
forall a b. a -> Either a b
Left (PublishError -> PublishFault
PublishRejected (Text -> PublishError
PublishError (Text
"publish failed with HTTP status " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
code)))

-- Pick the SRI (@dist.integrity@) string from the admitted digests, if present.
sriOf :: MirrorArtifact -> Maybe Text
sriOf :: MirrorArtifact -> Maybe Text
sriOf = HashAlg -> MirrorArtifact -> Maybe Text
firstHashValue HashAlg
SRI

-- Pick the SHA-1 shasum from the admitted digests, if present.
sha1Of :: MirrorArtifact -> Maybe Text
sha1Of :: MirrorArtifact -> Maybe Text
sha1Of = HashAlg -> MirrorArtifact -> Maybe Text
firstHashValue HashAlg
SHA1

{- | Build the publish @PUT /{pkg}@ request: the body is the npm publish
document (a packument carrying the version manifest and the base64 tarball under
@_attachments@), already serialised by the caller. Carries the bearer token and a
@Content-Type: application/json@ header.

Fails with a 'UrlFormationError' only when the URL cannot be formed; a genuine
write fault (a non-2xx, non-409 status) is the 'PublishError' that
'Ecluse.Core.Registry.publishArtifact' reports.
-}
publishRequest ::
    Text ->
    Maybe Secret ->
    PackageName ->
    ByteString ->
    Either UrlFormationError Request
publishRequest :: Text
-> Maybe Secret
-> PackageName
-> ByteString
-> Either UrlFormationError Request
publishRequest Text
baseUrl Maybe Secret
token PackageName
name ByteString
document = do
    url <- Text -> PackageName -> Either UrlFormationError Text
packageUrl Text
baseUrl PackageName
name
    base <- parseRequestEither url
    pure
        . withToken token
        $ base
            { method = "PUT"
            , requestBody = RequestBodyBS document
            , -- A spec-compliant registry (e.g. Verdaccio) rejects a publish whose
              -- body is not declared @application/json@ with a 415; the npm publish
              -- protocol requires it. Accept is set too, for the registry's response.
              requestHeaders =
                (hContentType, "application/json")
                    : (hAccept, "application/json")
                    : requestHeaders base
            }

{- | Assemble the npm publish document for one version from its verified tarball
bytes: the serialised body 'publishRequest' (hence
'Ecluse.Core.Registry.publishArtifact') @PUT@s to @/{pkg}@.

The document is the npm @PUT /{pkg}@ shape: the package name and a single-version
@versions@ map carrying the version manifest (@name@, @version@, and a @dist@ with
the integrity digests), @dist-tags.latest@ pointed at that version, and the tarball
itself base64-encoded under @_attachments@ with its byte @length@. A managed npm
registry (CodeArtifact, Artifact Registry, Verdaccio) recomputes the served
@dist.tarball@ location from the attachment, so the location is not carried.

The integrity digests written into @dist@ are the __caller's__: the worker passes
the serve-time-admitted digests it has already verified the bytes against: so the
published manifest's integrity matches exactly the bytes attached. The tarball
@length@ is taken from the actual byte count, never a caller-declared size, so the
attachment can never disagree with its own bytes.

This is the inverse of the read-side decode in "Ecluse.Core.Registry.Npm.Wire", which
deliberately does not model @_attachments@: it is constructed only here, for the
write.
-}
npmPublishDocument ::
    -- | The package being published.
    PackageName ->
    -- | The version being published.
    Version ->
    -- | The tarball's filename: the @_attachments@ key and tarball file segment.
    Text ->
    -- | The @dist.integrity@ SRI string, if known (e.g. @"sha512-…"@).
    Maybe Text ->
    -- | The @dist.shasum@ (SHA-1, hex), if known.
    Maybe Text ->
    -- | The verified tarball bytes.
    ByteString ->
    ByteString
npmPublishDocument :: PackageName
-> Version
-> Text
-> Maybe Text
-> Maybe Text
-> ByteString
-> ByteString
npmPublishDocument PackageName
name Version
version Text
filename Maybe Text
integrity Maybe Text
shasum ByteString
tarball =
    ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict (ByteString -> ByteString)
-> (Value -> ByteString) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$
        [Pair] -> Value
object
            [ Key
"_id" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
rendered
            , Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
rendered
            , Key
"dist-tags" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Key
"latest" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
versionText]
            , Key
"versions" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Text -> Key
Key.fromText Text
versionText Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
manifest]
            , Key
"_attachments" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Text -> Key
Key.fromText Text
filename Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Value
attachmentObject ByteString
tarball]
            ]
  where
    versionText :: Text
versionText = Version -> Text
renderVersion Version
version
    rendered :: Text
rendered = PackageName -> Text
renderPackageName PackageName
name
    manifest :: Value
manifest = Text -> Text -> Value -> Value
versionManifestObject Text
rendered Text
versionText (Text -> Maybe Text -> Maybe Text -> Value
distObject Text
filename Maybe Text
integrity Maybe Text
shasum)

-- The one-version manifest under @versions.{version}@: the package name, the
-- version, and its @dist@ descriptor.
versionManifestObject :: Text -> Text -> Aeson.Value -> Aeson.Value
versionManifestObject :: Text -> Text -> Value -> Value
versionManifestObject Text
rendered Text
versionText Value
dist =
    [Pair] -> Value
object
        [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
rendered
        , Key
"version" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
versionText
        , Key
"dist" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
dist
        ]

-- The manifest's @dist@ descriptor: the tarball filename plus whichever of the
-- caller's verified digests are known (an absent digest is omitted, never
-- fabricated).
distObject :: Text -> Maybe Text -> Maybe Text -> Aeson.Value
distObject :: Text -> Maybe Text -> Maybe Text -> Value
distObject Text
filename Maybe Text
integrity Maybe Text
shasum =
    [Pair] -> Value
object
        ( [Key
"tarball" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
filename]
            [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair] -> (Text -> [Pair]) -> Maybe Text -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
i -> [Key
"integrity" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
i]) Maybe Text
integrity
            [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair] -> (Text -> [Pair]) -> Maybe Text -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
s -> [Key
"shasum" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
s]) Maybe Text
shasum
        )

-- The @_attachments@ entry for the tarball, with the @length@ taken from the
-- actual byte count.
attachmentObject :: ByteString -> Aeson.Value
attachmentObject :: ByteString -> Value
attachmentObject ByteString
tarball =
    [Pair] -> Value
object
        [ Key
"content_type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"application/octet-stream" :: Text)
        , Key
"data" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
encodedTarball
        , Key
"length" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Int
BS.length ByteString
tarball
        ]
  where
    -- The npm attachment carries the raw tarball bytes, standard-base64-encoded.
    encodedTarball :: Text
    encodedTarball :: Text
encodedTarball = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 ByteString
tarball :: ByteString)

{- | Every package name a first-party npm publish body 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); a body that does not decode
to a JSON object declares no readable name (the empty list). The base64 @_attachments@
are never decoded.

This is the read-side inverse of 'npmPublishDocument', which assembles the same
@_id@\/@name@\/@versions@ shape for the mirror write. The ecosystem-neutral publish
pipeline injects it as its adapter's declared-name extractor, so the anti-shadowing
body-name guard (issue #391) can refuse a crafted body that names a package the scope
guard never authorised without the neutral pipeline knowing npm's document schema.
-}
declaredNames :: LByteString -> [Text]
declaredNames :: ByteString -> [Text]
declaredNames ByteString
body =
    [ Text
declared
    | Value
document <- Maybe Value -> [Value]
forall a. Maybe a -> [a]
maybeToList (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
body :: Maybe Value)
    , 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]
maybeToList (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]
    ]