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

{- | npm mirror publication through "Ecluse.Core.Registry.Publish", plus identity
extraction for the first-party publish guard. Published SRI retains all alternatives
at its strongest algorithm, matching the worker's verification contract. The published version
object keeps what the author wrote and strips what the public registry issued about itself, and
a plan whose version object is not an npm object is refused rather than reduced.
-}
module Ecluse.Core.Registry.Npm.Publish (
    npmPublishCodec,
    publishRequest,
    npmPublishDocument,
    declaredNames,
    npmPublishAllowed,
) where

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

import Lens.Micro ((^?))
import Lens.Micro.Aeson (key, _Object)
import Network.HTTP.Client (Request)

import Ecluse.Core.Credential (ClientCredential, Secret, bareCredential)
import Ecluse.Core.Package (HashAlg (SHA1, SRI), PackageName, Scope, hashAlg, hashValue, pkgNamespace, renderPackageName)
import Ecluse.Core.Package.Integrity (assertedAlg, authoritativeDigest)
import Ecluse.Core.Registry (
    FetchFault (FetchUrlUnformable),
    MirrorArtifact (maFilename, maHashes),
    PublishError (PublishError),
    PublishFault (PublishFetch, PublishRejected, PublishSourceUnavailable),
    UrlFormationError,
    firstHashValue,
    isSuccessStatus,
 )
import Ecluse.Core.Registry.CachedDocument (CachedDoc, npmCached)
import Ecluse.Core.Registry.Npm.Project qualified as Project
import Ecluse.Core.Registry.Npm.Request (MetadataForm (Abbreviated), jsonPutRequest, metadataRequest, packageUrl)
import Ecluse.Core.Registry.Publish (PublishCodec (..), PublishPlan (ppLatest, ppMetadata, ppVersion))
import Ecluse.Core.Server.Path (unFilename)
import Ecluse.Core.Version (renderVersion)

-- | Probe an abbreviated packument and publish verified bytes with their strongest SRI alternatives.
npmPublishCodec :: PublishCodec
npmPublishCodec :: PublishCodec
npmPublishCodec =
    PublishCodec
        { pcProbeRequest :: Text
-> Maybe Secret -> PackageName -> Either UrlFormationError Request
pcProbeRequest = \Text
targetUrl Maybe Secret
token -> Text
-> Maybe ClientCredential
-> MetadataForm
-> PackageName
-> Either UrlFormationError Request
metadataRequest Text
targetUrl (Secret -> ClientCredential
bareCredential (Secret -> ClientCredential)
-> Maybe Secret -> Maybe ClientCredential
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Secret
token) MetadataForm
Abbreviated
        , pcVersionListParser :: Limits -> Parser VersionListItem
pcVersionListParser = Limits -> Parser VersionListItem
Project.versionListParser
        , pcPublishRequest :: Text
-> Maybe Secret
-> PackageName
-> PublishPlan
-> MirrorArtifact
-> ByteString
-> Either PublishFault Request
pcPublishRequest = Text
-> Maybe Secret
-> PackageName
-> PublishPlan
-> MirrorArtifact
-> ByteString
-> Either PublishFault Request
npmPublishRequestFor
        , pcPublishOutcome :: Int -> Either PublishFault ()
pcPublishOutcome = Int -> Either PublishFault ()
classifyPublish
        }

npmPublishRequestFor ::
    Text ->
    Maybe Secret ->
    PackageName ->
    PublishPlan ->
    MirrorArtifact ->
    ByteString ->
    Either PublishFault Request
npmPublishRequestFor :: Text
-> Maybe Secret
-> PackageName
-> PublishPlan
-> MirrorArtifact
-> ByteString
-> Either PublishFault Request
npmPublishRequestFor Text
targetUrl Maybe Secret
token PackageName
name PublishPlan
plan MirrorArtifact
artifact ByteString
bytes = do
    document <-
        PackageName
-> PublishPlan
-> Text
-> Maybe Text
-> Maybe Text
-> ByteString
-> Either PublishFault ByteString
npmPublishDocument
            PackageName
name
            PublishPlan
plan
            (Filename -> Text
unFilename (MirrorArtifact -> Filename
maFilename MirrorArtifact
artifact))
            (MirrorArtifact -> Maybe Text
strongestSriValue MirrorArtifact
artifact)
            (HashAlg -> MirrorArtifact -> Maybe Text
firstHashValue HashAlg
SHA1 MirrorArtifact
artifact)
            ByteString
bytes
    first (PublishFetch . FetchUrlUnformable) (publishRequest targetUrl (bareCredential <$> token) name document)

strongestSriValue :: MirrorArtifact -> Maybe Text
strongestSriValue :: MirrorArtifact -> Maybe Text
strongestSriValue MirrorArtifact
artifact = do
    hashes <- [Hash] -> Maybe (NonEmpty Hash)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ((Hash -> Bool) -> [Hash] -> [Hash]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HashAlg -> HashAlg -> Bool
forall a. Eq a => a -> a -> Bool
== HashAlg
SRI) (HashAlg -> Bool) -> (Hash -> HashAlg) -> Hash -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> HashAlg
hashAlg) (NonEmpty Hash -> [Hash]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (MirrorArtifact -> NonEmpty Hash
maHashes MirrorArtifact
artifact)))
    let strongestAlg = Hash -> Maybe HashAlg
assertedAlg (NonEmpty Hash -> Hash
authoritativeDigest NonEmpty Hash
hashes)
    pure (T.unwords [hashValue h | h <- toList hashes, assertedAlg h == strongestAlg])

classifyPublish :: Int -> Either PublishFault ()
classifyPublish :: Int -> Either PublishFault ()
classifyPublish Int
code
    | Int -> Bool
isSuccessStatus Int
code = () -> 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)))

-- | Build the publish request with its credential, failing when the URL cannot be formed.
publishRequest ::
    Text ->
    Maybe ClientCredential ->
    PackageName ->
    ByteString ->
    Either UrlFormationError Request
publishRequest :: Text
-> Maybe ClientCredential
-> PackageName
-> ByteString
-> Either UrlFormationError Request
publishRequest Text
baseUrl Maybe ClientCredential
credential PackageName
name ByteString
document = do
    url <- Text -> PackageName -> Either UrlFormationError Text
packageUrl Text
baseUrl PackageName
name
    jsonPutRequest credential url document

{- | Assemble one version from the plan's metadata, under local authority for the name, version,
and verified @dist@ fields. The declared @latest@ is the plan's: a registry left to choose can retag.
-}
npmPublishDocument ::
    PackageName ->
    PublishPlan ->
    -- | 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 ->
    Either PublishFault ByteString
npmPublishDocument :: PackageName
-> PublishPlan
-> Text
-> Maybe Text
-> Maybe Text
-> ByteString
-> Either PublishFault ByteString
npmPublishDocument PackageName
name PublishPlan
plan Text
filename Maybe Text
integrity Maybe Text
shasum ByteString
tarball = do
    authored <- CachedDoc -> Either PublishFault (KeyMap Value)
authoredFields (PublishPlan -> CachedDoc
ppMetadata PublishPlan
plan)
    let manifest = Text -> Text -> Value -> KeyMap Value -> Value
versionManifestObject Text
rendered Text
versionText (Text -> Maybe Text -> Maybe Text -> KeyMap Value -> Value
distObject Text
filename Maybe Text
integrity Maybe Text
shasum (Key -> KeyMap Value -> KeyMap Value
objectAt Key
"dist" KeyMap Value
authored)) KeyMap Value
authored
    pure . toStrict . Aeson.encode $
        object
            [ "_id" .= rendered
            , "name" .= rendered
            , "dist-tags" .= object ["latest" .= renderVersion (ppLatest plan)]
            , "versions" .= object [Key.fromText versionText .= manifest]
            , "_attachments" .= object [Key.fromText filename .= attachmentObject tarball]
            ]
  where
    versionText :: Text
versionText = Version -> Text
renderVersion (PublishPlan -> Version
ppVersion PublishPlan
plan)
    rendered :: Text
rendered = PackageName -> Text
renderPackageName PackageName
name

-- Keep the shrinkwrap installation marker, but drop the source registry's bookkeeping.
authoredFields :: CachedDoc -> Either PublishFault (KeyMap Value)
authoredFields :: CachedDoc -> Either PublishFault (KeyMap Value)
authoredFields CachedDoc
doc = case (Value -> CachedDoc, CachedDoc -> Maybe Value)
-> CachedDoc -> Maybe Value
forall a b. (a, b) -> b
snd (Value -> CachedDoc, CachedDoc -> Maybe Value)
npmCached CachedDoc
doc of
    Just (Object KeyMap Value
o) -> KeyMap Value -> Either PublishFault (KeyMap Value)
forall a b. b -> Either a b
Right ((Key -> Value -> Bool) -> KeyMap Value -> KeyMap Value
forall v. (Key -> v -> Bool) -> KeyMap v -> KeyMap v
KeyMap.filterWithKey (\Key
k Value
_ -> Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
"_hasShrinkwrap" Bool -> Bool -> Bool
|| Bool -> Bool
not (Text -> Text -> Bool
T.isPrefixOf Text
"_" (Key -> Text
Key.toText Key
k))) KeyMap Value
o)
    Just Value
_ -> PublishFault -> Either PublishFault (KeyMap Value)
forall a b. a -> Either a b
Left (Text -> PublishFault
PublishSourceUnavailable Text
"the carried version object is not a JSON object")
    Maybe Value
Nothing -> PublishFault -> Either PublishFault (KeyMap Value)
forall a b. a -> Either a b
Left (Text -> PublishFault
PublishSourceUnavailable Text
"the carried version object is not an npm document")

objectAt :: Key.Key -> KeyMap Value -> KeyMap Value
objectAt :: Key -> KeyMap Value -> KeyMap Value
objectAt Key
slot KeyMap Value
o = case Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
slot KeyMap Value
o of
    Just (Object KeyMap Value
inner) -> KeyMap Value
inner
    Maybe Value
_ -> KeyMap Value
forall a. Monoid a => a
mempty

-- 'KeyMap.union' is left-biased, so the local authority fields win over the authored ones.
versionManifestObject :: Text -> Text -> Aeson.Value -> KeyMap Value -> Aeson.Value
versionManifestObject :: Text -> Text -> Value -> KeyMap Value -> Value
versionManifestObject Text
rendered Text
versionText Value
dist KeyMap Value
authored =
    KeyMap Value -> Value
Object ([Pair] -> KeyMap Value
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Key
"name", Text -> Value
String Text
rendered), (Key
"version", Text -> Value
String Text
versionText), (Key
"dist", Value
dist)] KeyMap Value -> KeyMap Value -> KeyMap Value
forall v. KeyMap v -> KeyMap v -> KeyMap v
`KeyMap.union` KeyMap Value
authored)

{- The verified location and digests replace the source's, and an unverified source digest never
survives their absence. Signatures and attestations reference the public registry's own keys. -}
distObject :: Text -> Maybe Text -> Maybe Text -> KeyMap Value -> Aeson.Value
distObject :: Text -> Maybe Text -> Maybe Text -> KeyMap Value -> Value
distObject Text
filename Maybe Text
integrity Maybe Text
shasum KeyMap Value
authored =
    KeyMap Value -> Value
Object (KeyMap Value
verified KeyMap Value -> KeyMap Value -> KeyMap Value
forall v. KeyMap v -> KeyMap v -> KeyMap v
`KeyMap.union` (Key -> Value -> Bool) -> KeyMap Value -> KeyMap Value
forall v. (Key -> v -> Bool) -> KeyMap v -> KeyMap v
KeyMap.filterWithKey (\Key
k Value
_ -> Key
k Key -> [Key] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Key]
registryDistKeys) KeyMap Value
authored)
  where
    verified :: KeyMap Value
verified =
        [Pair] -> KeyMap Value
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList
            ( (Key
"tarball", Text -> Value
String Text
filename)
                Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair] -> (Text -> [Pair]) -> Maybe Text -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
i -> [(Key
"integrity", Text -> Value
String 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", Text -> Value
String Text
s)]) Maybe Text
shasum
            )

registryDistKeys :: [Key.Key]
registryDistKeys :: [Key]
registryDistKeys = [Key
"tarball", Key
"integrity", Key
"shasum", Key
"signatures", Key
"attestations"]

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

-- | Read @_id@, @name@ and each version's name for the anti-shadowing guard. An undecodable body declares nothing.
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]
    ]

-- | Require an exact configured scope, refusing unscoped names and scope prefixes.
npmPublishAllowed :: [Scope] -> PackageName -> Bool
npmPublishAllowed :: [Scope] -> PackageName -> Bool
npmPublishAllowed [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