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

{- | Request shaping and URL building for the npm data plane, composed over the
ecosystem-agnostic mechanics in "Ecluse.Core.Registry.Request" (the outbound seal,
URL parsing, the path join, the opaque-artifact request core).

Three of npm's protocol facts are load-bearing here. Metadata comes in two forms chosen by
@Accept@, a scoped name travels as the single segment @\@scope%2Fname@, and an artifact
request must not decompress in flight, because the client verifies the relayed bytes
against the packument's @dist.integrity@.
-}
module Ecluse.Core.Registry.Npm.Request (
    -- * Content negotiation
    MetadataForm (..),

    -- * The ecosystem's artifact hosts
    npmArtifactHosts,

    -- * Request building
    metadataRequest,
    artifactRequestByFile,
    artifactRequestByUrl,
    artifactFileUrl,
    packageUrl,

    -- * Shared internals
    jsonPutRequest,
    withToken,
) where

import Network.HTTP.Client (
    Request (decompress, method, requestBody, requestHeaders),
    RequestBody (RequestBodyBS),
 )
import Network.HTTP.Types.Header (hAccept, hAcceptEncoding, hContentType)

import Ecluse.Core.Credential (ClientCredential)
import Ecluse.Core.Package (PackageName, pkgNamespace, renderPackageName, unScope, unscopedName)
import Ecluse.Core.Registry (UrlFormationError)
import Ecluse.Core.Registry.Npm.Credential (npmCredential)
import Ecluse.Core.Registry.Request (attachCredential, joinPath, parseRequestEither)
import Ecluse.Core.Registry.Request qualified as Request
import Ecluse.Core.Server.Path (encodeComponent)

-- | Which of npm's two metadata documents to request, selected by the @Accept@ header.
data MetadataForm
    = -- | The install view (@application/vnd.npm.install-v1+json@), which drops the @time@ map.
      Abbreviated
    | -- | The full packument (@application/json@), the only form carrying the @time@ map.
      Full
    deriving stock (MetadataForm -> MetadataForm -> Bool
(MetadataForm -> MetadataForm -> Bool)
-> (MetadataForm -> MetadataForm -> Bool) -> Eq MetadataForm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MetadataForm -> MetadataForm -> Bool
== :: MetadataForm -> MetadataForm -> Bool
$c/= :: MetadataForm -> MetadataForm -> Bool
/= :: MetadataForm -> MetadataForm -> Bool
Eq, Int -> MetadataForm -> ShowS
[MetadataForm] -> ShowS
MetadataForm -> String
(Int -> MetadataForm -> ShowS)
-> (MetadataForm -> String)
-> ([MetadataForm] -> ShowS)
-> Show MetadataForm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MetadataForm -> ShowS
showsPrec :: Int -> MetadataForm -> ShowS
$cshow :: MetadataForm -> String
show :: MetadataForm -> String
$cshowList :: [MetadataForm] -> ShowS
showList :: [MetadataForm] -> ShowS
Show)

metadataAccept :: MetadataForm -> ByteString
metadataAccept :: MetadataForm -> Method
metadataAccept = \case
    MetadataForm
Abbreviated -> Method
"application/vnd.npm.install-v1+json"
    MetadataForm
Full -> Method
"application/json"

{- | npm's canonical artifact hosts: none, because a registry serves its own tarball bytes.
The gate and the projection read this one list, so an artifact authority means one thing on both.
-}
npmArtifactHosts :: [Text]
npmArtifactHosts :: [Text]
npmArtifactHosts = []

{- | Build the metadata @GET@ request for a package at @{baseUrl}/{encoded-name}@. It asks for
@gzip@, because a popular packument is megabytes.
-}
metadataRequest ::
    Text ->
    Maybe ClientCredential ->
    MetadataForm ->
    PackageName ->
    Either UrlFormationError Request
metadataRequest :: Text
-> Maybe ClientCredential
-> MetadataForm
-> PackageName
-> Either UrlFormationError Request
metadataRequest Text
baseUrl Maybe ClientCredential
token MetadataForm
form PackageName
name = do
    url <- Text -> PackageName -> Either UrlFormationError Text
packageUrl Text
baseUrl PackageName
name
    base <- parseRequestEither url
    pure
        . withToken token
        $ base
            { requestHeaders =
                (hAccept, metadataAccept form)
                    : (hAcceptEncoding, "gzip")
                    : requestHeaders base
            }

{- | Build the artifact @GET@ at @{baseUrl}/{encoded-pkg}/-/{filename}@. It addresses the tarball by
the filename the client requested, so a registry with its own tarball naming still resolves.
-}
artifactRequestByFile ::
    Text ->
    Maybe ClientCredential ->
    PackageName ->
    Text ->
    Either UrlFormationError Request
artifactRequestByFile :: Text
-> Maybe ClientCredential
-> PackageName
-> Text
-> Either UrlFormationError Request
artifactRequestByFile Text
baseUrl Maybe ClientCredential
token PackageName
name Text
filename = do
    url <- Text -> PackageName -> Text -> Either UrlFormationError Text
artifactFileUrl Text
baseUrl PackageName
name Text
filename
    base <- parseRequestEither url
    pure
        . withToken token
        $ base
            { -- A @.tgz@ is opaque, already-compressed binary. It advertises no
              -- @Accept-Encoding@ either, because a doubly-gzipped body fails @dist.integrity@.
              decompress = const False
            }

{- | Build npm's artifact @GET@ for the absolute @url@ the projection preserved from the upstream's
@dist.tarball@, under npm's credential presentation.
-}
artifactRequestByUrl ::
    Maybe ClientCredential ->
    Text ->
    Either UrlFormationError Request
artifactRequestByUrl :: Maybe ClientCredential -> Text -> Either UrlFormationError Request
artifactRequestByUrl = CredentialMapping
-> Maybe ClientCredential
-> Text
-> Either UrlFormationError Request
Request.artifactRequestByUrl CredentialMapping
npmCredential

-- The metadata and publish URL for a package: @{baseUrl}/{encoded-name}@.
packageUrl :: Text -> PackageName -> Either UrlFormationError Text
packageUrl :: Text -> PackageName -> Either UrlFormationError Text
packageUrl Text
baseUrl PackageName
name =
    Text -> Text -> Either UrlFormationError Text
joinPath Text
baseUrl (PackageName -> Text
encodePackagePath PackageName
name)

{- | The artifact URL @{baseUrl}\/{encoded-name}\/-\/{encoded-filename}@, with @filename@
percent-encoded as one component so a once-decoded escape cannot reach the upstream raw.
-}
artifactFileUrl :: Text -> PackageName -> Text -> Either UrlFormationError Text
artifactFileUrl :: Text -> PackageName -> Text -> Either UrlFormationError Text
artifactFileUrl Text
baseUrl PackageName
name Text
filename =
    Text -> Text -> Either UrlFormationError Text
joinPath Text
baseUrl (PackageName -> Text
encodePackagePath PackageName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/-/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
encodeComponent Text
filename)

{- This builder writes the @\@@ and the @%2F@ itself and percent-encodes every component, so a
reserved byte in a decoded name never reaches the upstream URL raw. -}
encodePackagePath :: PackageName -> Text
encodePackagePath :: PackageName -> Text
encodePackagePath PackageName
name = case PackageName -> Maybe Scope
pkgNamespace PackageName
name of
    Just Scope
scope -> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
encodeComponent (Scope -> Text
unScope Scope
scope) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%2F" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
encodeComponent (PackageName -> Text
unscopedName PackageName
name)
    Maybe Scope
Nothing -> Text -> Text
encodeComponent (PackageName -> Text
renderPackageName PackageName
name)

{- | Build the JSON @PUT@ at @url@ carrying @document@, under the injected credential. An npm
registry answers 415 unless the body declares @application\/json@.
-}
jsonPutRequest :: Maybe ClientCredential -> Text -> ByteString -> Either UrlFormationError Request
jsonPutRequest :: Maybe ClientCredential
-> Text -> Method -> Either UrlFormationError Request
jsonPutRequest Maybe ClientCredential
credential Text
url Method
document = do
    base <- Text -> Either UrlFormationError Request
parseRequestEither Text
url
    pure
        . withToken credential
        $ base
            { method = "PUT"
            , requestBody = RequestBodyBS document
            , requestHeaders =
                (hContentType, "application/json")
                    : (hAccept, "application/json")
                    : requestHeaders base
            }

-- Attach the injected credential under npm's presentation. The redirect pin and the proxy
-- identity belong to Ecluse.Core.Registry.Request, which seals every request it parses.
withToken :: Maybe ClientCredential -> Request -> Request
withToken :: Maybe ClientCredential -> Request -> Request
withToken = CredentialMapping -> Maybe ClientCredential -> Request -> Request
attachCredential CredentialMapping
npmCredential