{- | The npm registry publish-document assembly and request shaping.

This module provides the pure data assembly for an npm publish request: forming
the JSON document from verified bytes and shaping the @PUT@ request. The actual
side-effecting relay and publish operations live in the top-level
"Ecluse.Core.Registry.Npm" client.
-}
module Ecluse.Core.Registry.Npm.Publish (
    publishRequest,
    npmPublishDocument,
) where

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

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 (PackageName, renderPackageName)
import Ecluse.Core.Registry (UrlFormationError)
import Ecluse.Core.Registry.Npm.Request (packageUrl, parseRequestEither, withToken)
import Ecluse.Core.Version (Version, renderVersion)

{- | 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)