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

{- | Project npm metadata into the shared package model.
Version-map keys identify artifacts independently of their filenames.
-}
module Ecluse.Core.Registry.Npm.Project (
    -- * Projection
    versionListParser,
    projectVersionEntryResult,

    -- * Name validation
    projectName,
    projectScope,
    npmNameLeadChars,
) where

import Data.Aeson (FromJSON (parseJSON), Value, withObject, (.:?))
import Data.Aeson.Types (Parser, parseEither)
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
import Data.JsonStream.Parser qualified as J
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Time (UTCTime)

import Ecluse.Core.Ecosystem (Ecosystem (Npm))
import Ecluse.Core.Package (
    Artifact (..),
    Availability (Available, Deprecated),
    CodeExecSignal (NoCodeOnInstall, RunsCodeOnInstall),
    Hash,
    HashAlg (SHA1),
    PackageDetails (..),
    PackageName,
    Scope,
    mkHash,
    mkPackageName,
    mkScope,
    mkSriHashes,
 )
import Ecluse.Core.Package.Entry (EntryKey (ObjectEntry))
import Ecluse.Core.Registry (ParseError (..))
import Ecluse.Core.Registry.Npm.Streaming (NpmContainer (VersionsContainer), NpmFieldOf (BeginContainer, InvalidContainer, VersionField), NpmRead (VersionListRead), npmFields)
import Ecluse.Core.Registry.Npm.Wire (
    Dist (..),
    VersionManifest (..),
 )
import Ecluse.Core.Registry.Npm.Wire qualified as Wire
import Ecluse.Core.Registry.VersionList (VersionListItem (..))
import Ecluse.Core.Registry.WireSupport (
    nameComponentWith,
    withinNameLimit,
 )
import Ecluse.Core.Security (Limits, maxNestingDepth)
import Ecluse.Core.Strict (strictElements)
import Ecluse.Core.Text (urlFilename)
import Ecluse.Core.Version (Version, mkVersion, renderVersion)

-- A decoded version object. A malformed @_npmUser@ drops the release, though nothing keeps it.
newtype VersionEntry = VersionEntry VersionManifest

instance FromJSON VersionEntry where
    parseJSON :: Value -> Parser VersionEntry
parseJSON Value
v =
        String
-> (Object -> Parser VersionEntry) -> Value -> Parser VersionEntry
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"npm version object" (\Object
o -> VersionManifest -> VersionEntry
VersionEntry (VersionManifest -> VersionEntry)
-> Parser VersionManifest -> Parser VersionEntry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser VersionManifest
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v Parser VersionEntry -> Parser (Maybe Person) -> Parser VersionEntry
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Object
o Object -> Key -> Parser (Maybe Person)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"_npmUser" :: Parser (Maybe Wire.Person))) Value
v

-- | Project a compact release while retaining the decoder reason for the invalid-entry report.
projectVersionEntryResult :: PackageName -> Version -> Maybe UTCTime -> Value -> Either String PackageDetails
projectVersionEntryResult :: PackageName
-> Version
-> Maybe UTCTime
-> Value
-> Either String PackageDetails
projectVersionEntryResult PackageName
name Version
version Maybe UTCTime
publishedAt Value
value =
    PackageName
-> Version -> Maybe UTCTime -> VersionEntry -> PackageDetails
projectDetails PackageName
name Version
version Maybe UTCTime
publishedAt (VersionEntry -> PackageDetails)
-> Either String VersionEntry -> Either String PackageDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser VersionEntry)
-> Value -> Either String VersionEntry
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser VersionEntry
forall a. FromJSON a => Value -> Parser a
parseJSON Value
value

-- | Recognise usable versions with only VersionEntry's discriminating fields and return sorted identifiers.
versionListParser :: Limits -> J.Parser VersionListItem
versionListParser :: Limits -> Parser VersionListItem
versionListParser Limits
limits = VersionListItem
-> VersionListItem
-> Parser VersionListItem
-> Parser VersionListItem
forall a. a -> a -> Parser a -> Parser a
J.objectFound VersionListItem
VersionListObject VersionListItem
VersionListObject (Parser (Maybe VersionListItem) -> Parser VersionListItem
forall a. Parser (Maybe a) -> Parser a
J.catMaybeI (NpmFieldOf Value -> Maybe VersionListItem
candidate (NpmFieldOf Value -> Maybe VersionListItem)
-> Parser (NpmFieldOf Value) -> Parser (Maybe VersionListItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> NpmRead -> Parser (NpmFieldOf Value)
npmFields (Limits -> Int
maxNestingDepth Limits
limits) NpmRead
VersionListRead))
  where
    candidate :: NpmFieldOf Value -> Maybe VersionListItem
candidate (BeginContainer NpmContainer
VersionsContainer) = VersionListItem -> Maybe VersionListItem
forall a. a -> Maybe a
Just VersionListItem
VersionListContainer
    candidate (InvalidContainer NpmContainer
VersionsContainer) = VersionListItem -> Maybe VersionListItem
forall a. a -> Maybe a
Just VersionListItem
VersionListInvalidContainer
    candidate (VersionField Text
key Maybe Value
raw) = VersionListItem -> Maybe VersionListItem
forall a. a -> Maybe a
Just (Maybe Version -> VersionListItem
VersionListEntry (if Maybe Value -> Bool
usable Maybe Value
raw then Version -> Maybe Version
forall a. a -> Maybe a
Just (Ecosystem -> Text -> Version
mkVersion Ecosystem
Npm Text
key) else Maybe Version
forall a. Maybe a
Nothing))
    candidate NpmFieldOf Value
_ = Maybe VersionListItem
forall a. Maybe a
Nothing
    usable :: Maybe Value -> Bool
usable Maybe Value
raw = Maybe VersionEntry -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Value
raw Maybe Value -> (Value -> Maybe VersionEntry) -> Maybe VersionEntry
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either String VersionEntry -> Maybe VersionEntry
forall l r. Either l r -> Maybe r
rightToMaybe (Either String VersionEntry -> Maybe VersionEntry)
-> (Value -> Either String VersionEntry)
-> Value
-> Maybe VersionEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Value -> Parser VersionEntry)
-> Value -> Either String VersionEntry
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser VersionEntry
forall a. FromJSON a => Value -> Parser a
parseJSON :: Value -> Either String VersionEntry))

-- Every field is evaluated here, so a retained release never keeps its decoded manifest alive.
projectDetails :: PackageName -> Version -> Maybe UTCTime -> VersionEntry -> PackageDetails
projectDetails :: PackageName
-> Version -> Maybe UTCTime -> VersionEntry -> PackageDetails
projectDetails PackageName
name Version
version Maybe UTCTime
publishedAt (VersionEntry VersionManifest
vm) =
    PackageDetails
        { pkgName :: PackageName
pkgName = PackageName
name
        , pkgVersion :: Version
pkgVersion = Version
version
        , pkgPublishedAt :: Maybe UTCTime
pkgPublishedAt = Maybe UTCTime
publishedAt
        , pkgInstallCode :: CodeExecSignal
pkgInstallCode = VersionManifest -> CodeExecSignal
installCode VersionManifest
vm
        , pkgAvailability :: Availability
pkgAvailability = VersionManifest -> Availability
availability VersionManifest
vm
        , pkgArtifacts :: NonEmpty Artifact
pkgArtifacts = (Artifact -> [Artifact] -> NonEmpty Artifact
forall a. a -> [a] -> NonEmpty a
:| []) (Artifact -> NonEmpty Artifact) -> Artifact -> NonEmpty Artifact
forall a b. (a -> b) -> a -> b
$! Version -> Dist -> Artifact
projectArtifact Version
version (VersionManifest -> Dist
vmDist VersionManifest
vm)
        }

{- Fail closed across two independent wire signals: a @false@ @hasInstallScript@ cannot hide a
hook the @scripts@ map declares. -}
installCode :: VersionManifest -> CodeExecSignal
installCode :: VersionManifest -> CodeExecSignal
installCode VersionManifest
vm
    | Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
hooks) =
        Text -> CodeExecSignal
RunsCodeOnInstall (Text
"declares install script(s): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
hooks)
    | VersionManifest -> Maybe Bool
vmHasInstallScript VersionManifest
vm Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True =
        Text -> CodeExecSignal
RunsCodeOnInstall Text
"declares an install script (hasInstallScript)"
    | Bool
otherwise = CodeExecSignal
NoCodeOnInstall
  where
    hooks :: [Text]
hooks = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Map Text Text -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` VersionManifest -> Map Text Text
vmScripts VersionManifest
vm) [Text]
installHooks

-- The lifecycle script names whose presence means installation runs code.
installHooks :: [Text]
installHooks :: [Text]
installHooks = [Text
"preinstall", Text
"install", Text
"postinstall"]

availability :: VersionManifest -> Availability
availability :: VersionManifest -> Availability
availability VersionManifest
vm = Availability
-> (Text -> Availability) -> Maybe Text -> Availability
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Availability
Available Text -> Availability
Deprecated (VersionManifest -> Maybe Text
vmDeprecated VersionManifest
vm)

{- The @tarball@ URL stays verbatim: "Ecluse.Core.Package.Filter" folds its scheme against the
https-only egress policy afterward. -}
projectArtifact :: Version -> Dist -> Artifact
projectArtifact :: Version -> Dist -> Artifact
projectArtifact Version
version Dist
dist =
    Artifact
        { artEntryKey :: EntryKey
artEntryKey = Text -> EntryKey
ObjectEntry (Version -> Text
renderVersion Version
version)
        , artFilename :: Text
artFilename = Text -> Version -> Text
tarballFilename (Dist -> Text
distTarball Dist
dist) Version
version
        , artUrl :: Text
artUrl = Dist -> Text
distTarball Dist
dist
        , artHashes :: [Hash]
artHashes = [Hash] -> [Hash]
forall (t :: * -> *) a. Foldable t => t a -> t a
strictElements ([Hash]
sriHashes [Hash] -> [Hash] -> [Hash]
forall a. Semigroup a => a -> a -> a
<> Maybe Hash -> [Hash]
forall a. Maybe a -> [a]
maybeToList Maybe Hash
sha1Hash)
        , artSize :: Maybe Int
artSize = Dist -> Maybe Int
distUnpackedSize Dist
dist
        }
  where
    -- A malformed digest is absent, never degenerate: no bogus fingerprint may pass the
    -- public-integrity admission gate (security.md invariant 5).
    toHash :: HashAlg -> Text -> Maybe Hash
    toHash :: HashAlg -> Text -> Maybe Hash
toHash HashAlg
alg = Either Text Hash -> Maybe Hash
forall l r. Either l r -> Maybe r
rightToMaybe (Either Text Hash -> Maybe Hash)
-> (Text -> Either Text Hash) -> Text -> Maybe Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashAlg -> Text -> Either Text Hash
mkHash HashAlg
alg
    -- One 'Hash' per @integrity@ component, so the admission floor and the worker's tamper
    -- gate rank and verify each digest exactly.
    sriHashes :: [Hash]
sriHashes = [Hash] -> (Text -> [Hash]) -> Maybe Text -> [Hash]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Text -> [Hash])
-> (NonEmpty Hash -> [Hash])
-> Either Text (NonEmpty Hash)
-> [Hash]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Hash] -> Text -> [Hash]
forall a b. a -> b -> a
const []) NonEmpty Hash -> [Hash]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Either Text (NonEmpty Hash) -> [Hash])
-> (Text -> Either Text (NonEmpty Hash)) -> Text -> [Hash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (NonEmpty Hash)
mkSriHashes) (Dist -> Maybe Text
distIntegrity Dist
dist)
    sha1Hash :: Maybe Hash
sha1Hash = Dist -> Maybe Text
distShasum Dist
dist Maybe Text -> (Text -> Maybe Hash) -> Maybe Hash
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashAlg -> Text -> Maybe Hash
toHash HashAlg
SHA1

-- Falls back to @\<version\>.tgz@ when the URL ends in a slash or names no file.
tarballFilename :: Text -> Version -> Text
tarballFilename :: Text -> Version -> Text
tarballFilename Text
url Version
version =
    Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Version -> Text
renderVersion Version
version Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".tgz") (Text -> Maybe Text
urlFilename Text
url)

{- | Parse an npm package name into the domain 'PackageName': the one splitter every npm entry
point reads a name through. A bare @\@foo@ is a malformed scoped name, never an unscoped one.
-}
projectName :: Text -> Either ParseError PackageName
projectName :: Text -> Either ParseError PackageName
projectName Text
raw = do
    Text -> Either ParseError ()
withinNpmNameLimit Text
raw
    if Text -> Text -> Bool
T.isPrefixOf Text
"@" Text
raw
        then Text -> Either ParseError PackageName
scopedName Text
raw
        else Ecosystem -> Maybe Scope -> Text -> PackageName
mkPackageName Ecosystem
Npm Maybe Scope
forall a. Maybe a
Nothing (Text -> PackageName)
-> Either ParseError Text -> Either ParseError PackageName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either ParseError Text
nameComponent Text
raw

{- Split a scoped @\@scope\/name@ at its one separator. A scope with nothing after it is a
malformed scoped name, so the whole string never falls back to an unscoped reading. -}
scopedName :: Text -> Either ParseError PackageName
scopedName :: Text -> Either ParseError PackageName
scopedName Text
raw = case Text -> Text -> Maybe Text
T.stripPrefix Text
"/" Text
afterScope of
    Maybe Text
Nothing -> ParseError -> Either ParseError PackageName
forall a b. a -> Either a b
Left (Text -> ParseError
ParseError (Text
"scoped npm name with no package name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
raw))
    Just Text
base -> do
        scope <- Text -> Either ParseError Scope
projectScope Text
scopeWire
        mkPackageName Npm (Just scope) <$> nameComponent base
  where
    (Text
scopeWire, Text
afterScope) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') Text
raw

{- | Parse an npm scope, with or without its leading @\@@ (@\@myorg@ and @myorg@ both give the
scope @myorg@).
-}
projectScope :: Text -> Either ParseError Scope
projectScope :: Text -> Either ParseError Scope
projectScope Text
raw = do
    -- Measure after the strip, so @myorg and myorg stay one scope at the cap as well as below it.
    Text -> Either ParseError ()
withinNpmNameLimit Text
bare
    Text -> Scope
mkScope (Text -> Scope)
-> Either ParseError Text -> Either ParseError Scope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either ParseError Text
nameComponent Text
bare
  where
    bare :: Text
bare = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
raw (Text -> Text -> Maybe Text
T.stripPrefix Text
"@" Text
raw)

{- One component of an npm name, the scope or the bare name. It sits on the shared name floor
and adds npm's own grammar. 'projectName' and 'projectScope' own the length cap. -}
nameComponent :: Text -> Either ParseError Text
nameComponent :: Text -> Either ParseError Text
nameComponent = Text -> (Text -> Bool) -> Text -> Either ParseError Text
nameComponentWith Text
"npm name component" Text -> Bool
usableComponent

usableComponent :: Text -> Bool
usableComponent :: Text -> Bool
usableComponent Text
component =
    (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
npmNameChar Text
component
        Bool -> Bool -> Bool
&& Int -> Text -> Text
T.take Int
1 Text
component Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Text
".", Text
"-", Text
"_"]
        Bool -> Bool -> Bool
&& Text -> Text
T.toLower Text
component Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Text]
reservedNames

-- @ and / are scope structure, which 'projectName' and 'scopedName' read, so a part carries
-- neither.
npmNameChar :: Char -> Bool
npmNameChar :: Char -> Bool
npmNameChar Char
ch = Char -> Bool
isAsciiUpper Char
ch Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
ch Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
ch Bool -> Bool -> Bool
|| Char
ch Char -> String -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` String
npmNameSpecials

-- The punctuation npm's own name grammar admits outside the alphanumerics.
npmNameSpecials :: [Char]
npmNameSpecials :: String
npmNameSpecials = String
"-_.!~*'()"

{- | Every character an npm package name may begin with, sieved out of ASCII by the grammar
above so the store walk's bucket alphabet cannot drift from what this module parses.
-}
npmNameLeadChars :: [Char]
npmNameLeadChars :: String
npmNameLeadChars = [Char
ch | Char
ch <- [Char
'\0' .. Char
'\127'], Char -> Bool
npmNameChar Char
ch, Text -> Bool
usableComponent (Char -> Text
T.singleton Char
ch)]

-- The two names npm refuses outright, each because it collides with a path npm itself writes.
reservedNames :: [Text]
reservedNames :: [Text]
reservedNames = [Text
"node_modules", Text
"favicon.ico"]

{- Refuse a name over npm's own cap. 'projectName' measures the whole name including any scope
prefix, and 'projectScope' measures a bare scope. -}
withinNpmNameLimit :: Text -> Either ParseError ()
withinNpmNameLimit :: Text -> Either ParseError ()
withinNpmNameLimit = Text -> Int -> Text -> Either ParseError ()
withinNameLimit Text
"npm name" Int
npmNameLimit

-- npm's own cap on a package name, the one its validator applies to a new package.
npmNameLimit :: Int
npmNameLimit :: Int
npmNameLimit = Int
214