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

{- | Projection of npm wire JSON into the ecosystem-agnostic domain model.

This module is the second half of the npm protocol boundary. Where
"Ecluse.Core.Registry.Npm.Wire" captures /what the registry said/ as faithful wire
types, this module turns those into the domain vocabulary of "Ecluse.Core.Package" --
'PackageInfo' (the packument-level view) and 'PackageDetails' (the per-version
snapshot the rules engine evaluates). Together they realise the @parse*@ fields
of the "Ecluse.Core.Registry" handle: nothing above the adapter ever sees npm wire
data.

The projection is __pure and total__ (it returns 'Either' 'ParseError', never
throws), the execution half of /parse, don't validate/ -- once a response has
been projected, downstream code holds precise domain types and never re-inspects
the wire shape.

== Per-version graceful degradation

The @versions@, @dist-tags@, and @time@ maps are decoded __element-wise__: a
version whose manifest is missing or malformed in a required\/security-decisive
field (no @dist@ or @tarball@, an unusable @version@), a @dist-tags@ entry whose
value is not a string, or a @time@ entry that is not a decodable instant is
__dropped__ rather than failing the whole packument. Because presence in the
decision surface is what makes a version a serve-candidate, a dropped version is
automatically never served -- fail-closed for that one version (a version that
cannot be decoded cannot be evaluated for integrity, CVEs, or rules) while every
healthy version still resolves; a dropped date is simply a version with no known
publish time, and a dropped tag loses only that one tag. Only a document whose
/top-level/ structure is unusable (a @versions@ that is not an object, an
absent\/empty @name@) is denied wholesale. A version's purely __advisory__ fields
degrade in the wire layer ("Ecluse.Core.Registry.Npm.Wire") without dropping the
version. Every drop is __recorded__ as an 'Ecluse.Core.Package.InvalidEntry' in
'Ecluse.Core.Package.infoInvalidEntries' (a version-manifest, dist-tag, or
publish-time drop, each carrying its key and reason), so the serve path can log
what an upstream served malformed rather than dropping it silently.

== Signal mapping

The npm-specific fields collapse onto the normalised, ecosystem-blind signals:

* install-script presence → 'CodeExecSignal', read __fail-closed__ across two
  independent wire signals. A version runs code on install when /either/ the
  abbreviated form's @hasInstallScript@ flag is @true@ /or/ the @scripts@ map
  declares any of @preinstall@\/@install@\/@postinstall@ (matching what npm
  itself sets the flag from). The two fields are independent on the wire, so the
  @scripts@ map is consulted __even when @hasInstallScript@ is present and
  @false@__: a hostile upstream must not be able to mask a real install hook by
  lying in the sibling flag, so a declared script is authoritative and the
  signal is the union of the two, never the flag overriding a script. A version
  with neither signal maps to 'NoCodeOnInstall' (both metadata forms always
  carry the @scripts@\/@hasInstallScript@ information, so its absence is a
  determination, not an unknown).
* @deprecated@ → 'Availability': a notice yields 'Deprecated' (carrying the
  message), its absence 'Available'. npm has no per-version yank, so @Yanked@
  never arises here.
* @dist@ → a single-element 'NonEmpty' of 'Artifact' (npm publishes exactly one
  tarball per version). __Both__ integrity digests survive when present and
  __well-formed__: @dist.shasum@ as a 'SHA1' 'Hash' /and/ @dist.integrity@ as an
  'SRI' 'Hash'. Carrying both is load-bearing -- a cross-upstream merge compares the
  same version's integrity across the private and public registries to detect a
  supply-chain divergence, which dropping either digest would blind. Each digest is
  built through the validating 'mkHash', so a __malformed__ one -- empty
  (@"shasum":""@ \/ @"integrity":""@), truncated, non-hex, or bad-base64 -- is
  unconstructable and so treated as __absent__, never as a degenerate 'Hash': a
  digest that ties the version to no tamper-evident fingerprint must not slip past
  the public-integrity admission gate.
* @_npmUser@ → 'pkgPublisher' (who pushed this version -- provenance). It rides
  on the version object but is not modelled by the wire manifest, so the
  projection reads it directly from the version object here.
* @time[version]@ → 'pkgPublishedAt'. The publish timestamp lives in the
  packument's @time@ map, not the manifest; a version with no @time@ entry (or
  an abbreviated document, which omits @time@) projects to 'Nothing'.

Trust is left 'TrustUnknown': establishing it needs signature verification
against npm's published keys, a fetch this pure projection does not perform.

== Name as a validation input

The requested 'PackageName' -- the identity the proxy resolved from the route -- is
the __validation authority__ for the served packument's name, never a rewrite of
it. The packument projection takes the requested name and checks the upstream's
self-reported top-level @name@ against it: a document whose self-report agrees is a
'Projected' 'PackageInfo' carrying the name the upstream genuinely reported; a
document whose self-report __disagrees__ is a 'NameMismatch', so the caller can
treat that origin as untrusted for this request and drop its contribution. The
served name is therefore always a value an upstream genuinely reported, never a
substituted or manufactured one. An /absent/ or otherwise undecodable name remains
a 'ParseError', as before -- distinct from a present-but-different name.
-}
module Ecluse.Core.Registry.Npm.Project (
    -- * Projection
    parsePackageInfoFromValue,
    parseVersionList,
    projectVersionEntry,

    -- * Name validation
    Projection (..),
    projectName,
) where

import Data.Aeson (FromJSON (parseJSON), Object, Value, eitherDecodeStrict, withObject, (.!=), (.:?))
import Data.Aeson.Types (Parser, parseEither, parseMaybe)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Time (UTCTime)

import Ecluse.Core.Ecosystem (Ecosystem (Npm))
import Ecluse.Core.Package (
    Artifact (..),
    ArtifactKind (Tarball),
    Availability (Available, Deprecated),
    CodeExecSignal (NoCodeOnInstall, RunsCodeOnInstall),
    Hash,
    HashAlg (SHA1),
    InvalidEntry (..),
    InvalidEntryKind (InvalidDistTag, InvalidPublishTime, InvalidVersionManifest),
    PackageDetails (..),
    PackageInfo (..),
    PackageName,
    Person (..),
    Scope,
    Trust (TrustUnknown),
    mkHash,
    mkPackageName,
    mkScope,
    mkSriHashes,
 )
import Ecluse.Core.Registry (ParseError (..), RegistryResponse (responseBody))
import Ecluse.Core.Registry.Npm.Wire (
    Dist (..),
    License (LicenseObject, LicenseSpdx),
    VersionManifest (..),
 )
import Ecluse.Core.Registry.Npm.Wire qualified as Wire
import Ecluse.Core.Registry.WireSupport (
    NameAgreement (NameAgrees, NameDisagrees),
    checkNameAgreement,
    partitionLenient,
 )
import Ecluse.Core.Text (lastPathSegment)
import Ecluse.Core.Version (Version, mkVersion, unVersion)

{- The packument as this projection needs to read it: the wire fields plus the
per-version @_npmUser@ that "Ecluse.Core.Registry.Npm.Wire" intentionally leaves off
the manifest. Decoding the version objects here (rather than through the wire
'VersionManifest' alone) is what lets the publisher survive, since the wire manifest
has already discarded it.
-}
data WirePackument = WirePackument
    { WirePackument -> Text
wpName :: Text
    , WirePackument -> Map Text Text
wpDistTags :: Map Text Text
    , WirePackument -> Map Text VersionEntry
wpVersions :: Map Text VersionEntry
    , WirePackument -> Map Text UTCTime
wpTime :: Map Text UTCTime
    , WirePackument -> [InvalidEntry]
wpInvalidEntries :: [InvalidEntry]
    -- ^ The malformed @versions@\/@dist-tags@\/@time@ entries dropped during decode.
    }

instance FromJSON WirePackument where
    parseJSON :: Value -> Parser WirePackument
parseJSON = String
-> (Object -> Parser WirePackument)
-> Value
-> Parser WirePackument
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"npm packument" ((Object -> Parser WirePackument) -> Value -> Parser WirePackument)
-> (Object -> Parser WirePackument)
-> Value
-> Parser WirePackument
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        name <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"name" Parser (Maybe Text) -> Text -> Parser Text
forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
""
        (distTags, distTagDrops) <- lenientDistTags o
        (versions, versionDrops) <- lenientVersionMap o
        (time, timeDrops) <- lenientTimeMap (Map.keysSet versions) o
        pure
            WirePackument
                { wpName = name
                , wpDistTags = distTags
                , wpVersions = versions
                , wpTime = time
                , -- Deterministic order (versions, then dist-tags, then time), each
                  -- already in ascending-key order, so the dropped-entry list is stable.
                  wpInvalidEntries = versionDrops <> distTagDrops <> timeDrops
                }

{- Decode the @versions@ map __element-wise leniently__: read it as a raw map of
version key to 'Value', then keep only the entries that project to a 'VersionEntry',
dropping any that do not and recording each as an 'InvalidVersionManifest'. A version
whose manifest is missing or malformed in a required\/security-decisive field (no
@dist@\/@tarball@, an unusable @version@) is __dropped from the decision surface__
rather than failing the whole packument: fail-closed for that version (a version that
cannot be decoded cannot be evaluated for integrity, CVEs, or rules, so it must never
be served) while every healthy version still decodes. An absent @versions@ is the empty
map; a @versions@ that is not an object at all still fails the decode (the document is
not a usable packument). -}
lenientVersionMap :: Object -> Parser (Map Text VersionEntry, [InvalidEntry])
lenientVersionMap :: Object -> Parser (Map Text VersionEntry, [InvalidEntry])
lenientVersionMap Object
o = do
    raw <- Object
o Object -> Key -> Parser (Maybe (Map Text Value))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"versions" Parser (Maybe (Map Text Value))
-> Map Text Value -> Parser (Map Text Value)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map Text Value
forall a. Monoid a => a
mempty -- Map Text Value: each version object kept raw
    pure (partitionLenient InvalidVersionManifest (parseEither parseJSON) raw)

{- Decode the @dist-tags@ map __element-wise leniently__: read it as a raw map of tag
name to 'Value', keeping each entry whose value is a JSON string and dropping any that
is not (recording it as an 'InvalidDistTag'). A single non-string tag value therefore
loses only that tag rather than failing the whole document. A string that is not a
valid version is still kept here ('mkVersion' is total, so dist-tag /targeting/ is
reconciled later, never a decode failure). -}
lenientDistTags :: Object -> Parser (Map Text Text, [InvalidEntry])
lenientDistTags :: Object -> Parser (Map Text Text, [InvalidEntry])
lenientDistTags Object
o = do
    raw <- Object
o Object -> Key -> Parser (Maybe (Map Text Value))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"dist-tags" Parser (Maybe (Map Text Value))
-> Map Text Value -> Parser (Map Text Value)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map Text Value
forall a. Monoid a => a
mempty
    pure (partitionLenient InvalidDistTag (parseEither parseJSON) raw)

{- Decode the @time@ map __element-wise leniently__: read it as a raw map of key to
'Value', keeping each entry that decodes as an instant and dropping any that does not.
With the publish time folded onto each version, a malformed sibling date is simply a
version with no known publish time, never a document failure. Only a drop keyed by a
__present version__ is recorded (as an 'InvalidPublishTime'); the @created@\/@modified@
bookkeeping keys are package-level, not a version's publish time, so a malformed one is
not a per-version drop and is left untracked. -}
lenientTimeMap :: Set Text -> Object -> Parser (Map Text UTCTime, [InvalidEntry])
lenientTimeMap :: Set Text -> Object -> Parser (Map Text UTCTime, [InvalidEntry])
lenientTimeMap Set Text
versionKeys Object
o = do
    raw <- Object
o Object -> Key -> Parser (Maybe (Map Text Value))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"time" Parser (Maybe (Map Text Value))
-> Map Text Value -> Parser (Map Text Value)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map Text Value
forall a. Monoid a => a
mempty
    let (kept, dropped) = partitionLenient InvalidPublishTime (parseEither parseJSON) raw
    pure (kept, filter ((`Set.member` versionKeys) . invalidKey) dropped)

{- A decoded version object: the wire 'VersionManifest' plus its @_npmUser@
publisher. Both are decoded from the /same/ object in one pass, so there is a
single notion of what a version object is.
-}
data VersionEntry = VersionEntry
    { VersionEntry -> VersionManifest
veManifest :: VersionManifest
    , VersionEntry -> Maybe Person
vePublisher :: Maybe Wire.Person
    }

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 -> Maybe Person -> VersionEntry
VersionEntry (VersionManifest -> Maybe Person -> VersionEntry)
-> Parser VersionManifest -> Parser (Maybe Person -> 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 (Maybe Person -> VersionEntry)
-> Parser (Maybe Person) -> Parser VersionEntry
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Person)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"_npmUser") Value
v

{- | The outcome of projecting an upstream packument against the requested package
name (see the module header, "Name as a validation input").

The requested name validates the document; it never rewrites it. A document whose
self-reported name agrees with the request is 'Projected'; one that disagrees is a
'NameMismatch'. The 'PackageInfo' of a 'Projected' carries the name the upstream
genuinely reported (which, having matched, equals the requested name) -- never a
substituted value.
-}
data Projection
    = -- | The document decoded and its self-reported name matched the request.
      Projected PackageInfo
    | -- | The document decoded but self-reported this /different/ name (carried verbatim for the audit log).
      NameMismatch Text
    deriving stock (Projection -> Projection -> Bool
(Projection -> Projection -> Bool)
-> (Projection -> Projection -> Bool) -> Eq Projection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Projection -> Projection -> Bool
== :: Projection -> Projection -> Bool
$c/= :: Projection -> Projection -> Bool
/= :: Projection -> Projection -> Bool
Eq, Int -> Projection -> ShowS
[Projection] -> ShowS
Projection -> String
(Int -> Projection -> ShowS)
-> (Projection -> String)
-> ([Projection] -> ShowS)
-> Show Projection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Projection -> ShowS
showsPrec :: Int -> Projection -> ShowS
$cshow :: Projection -> String
show :: Projection -> String
$cshowList :: [Projection] -> ShowS
showList :: [Projection] -> ShowS
Show)

{- | Project an __already-decoded__ packument @Value@ into a 'Projection' for the
requested package, without re-parsing any bytes. This is the entry point the serve
layer uses when it has already decoded the upstream body to a raw @Value@ (the
document it edits in place to serve) and wants the typed view of the /same/
document: projecting from the @Value@ reuses that one parse rather than tokenising
the bytes a second time. Pure and total -- a @Value@ that is not a decodable npm
packument is reported as a 'ParseError', never thrown.

The requested name validates the self-reported @name@: a match is 'Projected', a
disagreement is 'NameMismatch'. The serve layer drops a 'NameMismatch' origin's
contribution (an untrusted, misreporting upstream) and keeps the served name a value
some upstream genuinely reported.
-}
parsePackageInfoFromValue :: PackageName -> Value -> Either ParseError Projection
parsePackageInfoFromValue :: PackageName -> Value -> Either ParseError Projection
parsePackageInfoFromValue PackageName
requestedName Value
value =
    Value -> Either ParseError WirePackument
decodePackumentValue Value
value Either ParseError WirePackument
-> (WirePackument -> Either ParseError Projection)
-> Either ParseError Projection
forall a b.
Either ParseError a
-> (a -> Either ParseError b) -> Either ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PackageName -> WirePackument -> Either ParseError Projection
projectValidated PackageName
requestedName

{- Project + validate a decoded packument against the requested name. The genuine
self-reported name (from 'projectPackageInfo', which fails an absent\/empty name as a
'ParseError') is checked against the request by the shared 'checkNameAgreement': agreement
yields 'Projected' carrying the genuine 'PackageInfo', a disagreement a 'NameMismatch'
carrying what the upstream reported. The name is never substituted. -}
projectValidated :: PackageName -> WirePackument -> Either ParseError Projection
projectValidated :: PackageName -> WirePackument -> Either ParseError Projection
projectValidated PackageName
requestedName WirePackument
pkmt = do
    info <- WirePackument -> Either ParseError PackageInfo
projectPackageInfo WirePackument
pkmt
    pure $ case checkNameAgreement requestedName (infoName info) of
        NameAgreement
NameAgrees -> PackageInfo -> Projection
Projected PackageInfo
info
        NameDisagrees Text
reported -> Text -> Projection
NameMismatch Text
reported

-- Project a decoded 'WirePackument' into the domain 'PackageInfo', taking the name
-- from the upstream's self-reported @name@ (validated against the request by
-- 'projectValidated'). Shared by the validating entry points and the version-detail
-- accessor so the projection lives in one place.
projectPackageInfo :: WirePackument -> Either ParseError PackageInfo
projectPackageInfo :: WirePackument -> Either ParseError PackageInfo
projectPackageInfo WirePackument
pkmt = do
    name <- Text -> Either ParseError PackageName
projectName (WirePackument -> Text
wpName WirePackument
pkmt)
    pure
        PackageInfo
            { infoName = name
            , infoVersions = projectVersions name pkmt
            , infoDistTags = projectDistTags pkmt
            , infoInvalidEntries = wpInvalidEntries pkmt
            }

{- | Project a __single version object__ -- one entry of a packument's @versions@ map,
as a raw 'Value' -- into its 'PackageDetails', given the requested package name, the
version key it sits under, and its publish time (the packument's @time[version]@, if
present). 'Nothing' when the version object does not decode in a required\/security-
decisive field, exactly the per-version drop the full packument projection applies.

This is the per-version projection step factored out so a __selective__ single-version
decode (see "Ecluse.Core.Registry.Npm.SelectiveDecode"), which extracts only the one
version object and its publish time from the packument bytes, projects it through the
__same__ code the whole-packument path runs over every version -- so the resulting
'PackageDetails' is identical to @'Map.lookup'@-ing the version out of a full
'parsePackageInfoFromValue' projection. The element-wise leniency is identical too: a version object missing
its @dist@\/@tarball@ (or otherwise unprojectable) yields 'Nothing', i.e. a genuine
absence, never a half-built snapshot.
-}
projectVersionEntry :: PackageName -> Version -> Maybe UTCTime -> Value -> Maybe PackageDetails
projectVersionEntry :: PackageName
-> Version -> Maybe UTCTime -> Value -> Maybe PackageDetails
projectVersionEntry 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)
-> Maybe VersionEntry -> Maybe PackageDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser VersionEntry) -> Value -> Maybe VersionEntry
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser VersionEntry
forall a. FromJSON a => Value -> Parser a
parseJSON Value
value

{- | Extract the list of available versions from a fetched metadata response, in
the packument's @versions@ key order. Fails with a 'ParseError' only if the body
does not decode.
-}
parseVersionList :: RegistryResponse -> Either ParseError [Version]
parseVersionList :: RegistryResponse -> Either ParseError [Version]
parseVersionList RegistryResponse
resp = do
    pkmt <- RegistryResponse -> Either ParseError WirePackument
decodePackument RegistryResponse
resp
    pure (map (mkVersion Npm) (Map.keys (wpVersions pkmt)))

{- Decode a response body into a 'WirePackument', adapting aeson's 'String'
error into a domain 'ParseError'.
-}
decodePackument :: RegistryResponse -> Either ParseError WirePackument
decodePackument :: RegistryResponse -> Either ParseError WirePackument
decodePackument =
    (String -> ParseError)
-> Either String WirePackument -> Either ParseError WirePackument
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> ParseError
ParseError (Text -> ParseError) -> (String -> Text) -> String -> ParseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText) (Either String WirePackument -> Either ParseError WirePackument)
-> (RegistryResponse -> Either String WirePackument)
-> RegistryResponse
-> Either ParseError WirePackument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String WirePackument
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict (ByteString -> Either String WirePackument)
-> (RegistryResponse -> ByteString)
-> RegistryResponse
-> Either String WirePackument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegistryResponse -> ByteString
responseBody

{- Project an already-decoded 'Value' into a 'WirePackument' via its 'FromJSON'
instance, adapting aeson's 'String' error into a domain 'ParseError'. The result is
identical to 'decodePackument' on the bytes that produced the @Value@: aeson decodes
to a 'Value' and then runs the same 'FromJSON' instance either way, so this reuses
the one parse instead of tokenising the bytes again.
-}
decodePackumentValue :: Value -> Either ParseError WirePackument
decodePackumentValue :: Value -> Either ParseError WirePackument
decodePackumentValue =
    (String -> ParseError)
-> Either String WirePackument -> Either ParseError WirePackument
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> ParseError
ParseError (Text -> ParseError) -> (String -> Text) -> String -> ParseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText) (Either String WirePackument -> Either ParseError WirePackument)
-> (Value -> Either String WirePackument)
-> Value
-> Either ParseError WirePackument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser WirePackument)
-> Value -> Either String WirePackument
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser WirePackument
forall a. FromJSON a => Value -> Parser a
parseJSON

{- Project every entry of the packument's @versions@ map into a
'PackageDetails', keyed by the raw version string (the packument's own key).
-}
projectVersions :: PackageName -> WirePackument -> Map Text PackageDetails
projectVersions :: PackageName -> WirePackument -> Map Text PackageDetails
projectVersions PackageName
name WirePackument
pkmt =
    (Text -> VersionEntry -> PackageDetails)
-> Map Text VersionEntry -> Map Text PackageDetails
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Text -> VersionEntry -> PackageDetails
projectAt (WirePackument -> Map Text VersionEntry
wpVersions WirePackument
pkmt)
  where
    projectAt :: Text -> VersionEntry -> PackageDetails
projectAt Text
rawVersion =
        PackageName
-> Version -> Maybe UTCTime -> VersionEntry -> PackageDetails
projectDetails
            PackageName
name
            (Ecosystem -> Text -> Version
mkVersion Ecosystem
Npm Text
rawVersion)
            (Text -> Map Text UTCTime -> Maybe UTCTime
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
rawVersion (WirePackument -> Map Text UTCTime
wpTime WirePackument
pkmt))

{- Build a 'PackageDetails' from one projected version entry and its publish
time (if the packument's @time@ map carried one).
-}
projectDetails :: PackageName -> Version -> Maybe UTCTime -> VersionEntry -> PackageDetails
projectDetails :: PackageName
-> Version -> Maybe UTCTime -> VersionEntry -> PackageDetails
projectDetails PackageName
name Version
version Maybe UTCTime
publishedAt VersionEntry
entry =
    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
        , pkgTrust :: Trust
pkgTrust = Trust
TrustUnknown
        , pkgAvailability :: Availability
pkgAvailability = VersionManifest -> Availability
availability VersionManifest
vm
        , pkgArtifacts :: NonEmpty Artifact
pkgArtifacts = Version -> Dist -> Artifact
projectArtifact Version
version (VersionManifest -> Dist
vmDist VersionManifest
vm) Artifact -> [Artifact] -> NonEmpty Artifact
forall a. a -> [a] -> NonEmpty a
:| []
        , pkgLicenses :: [Text]
pkgLicenses = [Text] -> (License -> [Text]) -> Maybe License -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Text -> [Text]
OneItem [Text] -> [Text]
forall x. One x => OneItem x -> x
one (Text -> [Text]) -> (License -> Text) -> License -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. License -> Text
licenseText) (VersionManifest -> Maybe License
vmLicense VersionManifest
vm)
        , pkgPublisher :: Maybe Person
pkgPublisher = Person -> Person
projectPerson (Person -> Person) -> Maybe Person -> Maybe Person
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VersionEntry -> Maybe Person
vePublisher VersionEntry
entry
        }
  where
    vm :: VersionManifest
vm = VersionEntry -> VersionManifest
veManifest VersionEntry
entry

-- The SPDX expression or license name carried by a wire 'License'.
licenseText :: License -> Text
licenseText :: License -> Text
licenseText = \case
    LicenseSpdx Text
spdx -> Text
spdx
    LicenseObject Text
name Maybe Text
_url -> Text
name

{- Map npm install-script presence onto 'CodeExecSignal', failing closed across
the two independent wire signals: a version runs code on install when /either/
the @scripts@ map declares an install hook
(@preinstall@\/@install@\/@postinstall@) /or/ the abbreviated form's
@hasInstallScript@ flag is @true@. The @scripts@ map is consulted __even when
the flag is present and @false@__ -- the two fields are independent on the wire,
so a hostile upstream cannot suppress a manifest's own declared install hook by
setting @hasInstallScript:false@ beside it. A declared script is authoritative;
the flag only contributes the abbreviated-form signal (where @scripts@ is
stripped), it never overrides a script the manifest itself carries.
-}
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"]

-- Map an optional @deprecated@ notice onto 'Availability'.
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)

{- Project the @dist@ object into an 'Artifact', carrying __both__ integrity
digests: the legacy SHA-1 @shasum@ and the modern @integrity@ SRI string. Each
present, non-empty digest becomes an algorithm-tagged 'Hash'; a content-empty
digest is treated as absent, so neither a real digest is dropped nor an empty one
fabricated. The @dist.tarball@ URL is carried verbatim here; its scheme is normalised
against the https-only egress policy afterward by the egress-scheme fold in
"Ecluse.Core.Package.Filter".
-}
projectArtifact :: Version -> Dist -> Artifact
projectArtifact :: Version -> Dist -> Artifact
projectArtifact Version
version Dist
dist =
    Artifact
        { artFilename :: Text
artFilename = Text -> Version -> Text
tarballFilename (Dist -> Text
distTarball Dist
dist) Version
version
        , artUrl :: Text
artUrl = Dist -> Text
distTarball Dist
dist
        , artKind :: ArtifactKind
artKind = ArtifactKind
Tarball
        , artHashes :: [Hash]
artHashes = [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
        , artInterpreter :: Maybe Text
artInterpreter = Maybe Text
forall a. Maybe a
Nothing
        , artYanked :: Bool
artYanked = Bool
False
        , artProvenance :: Maybe Text
artProvenance = Maybe Text
forall a. Maybe a
Nothing
        }
  where
    -- Build each present digest through the validating 'mkHash'; a malformed value (the
    -- empty string @"shasum":""@ / @"integrity":""@, but equally a truncated or non-hex
    -- one) is unconstructable, so it becomes absent rather than a degenerate 'Hash'. A
    -- digest that ties the version to no tamper-evident fingerprint must not slip past the
    -- public-integrity admission gate (security.md invariant 5) or feed a bogus fingerprint
    -- to the cross-upstream divergence check; dropping it here leaves the now-hashless
    -- version to be classified NoIntegrity by Ecluse.Core.Package.Integrity.
    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
    -- A multi-component @integrity@ (rare on npm, legal SRI) is split into one
    -- 'Hash' per component ('mkSriHashes'), so the strongest-digest selection at
    -- the admission floor and the worker's tamper gate rank and verify each
    -- component exactly -- never a joined string read two different ways.
    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

{- The artifact filename for a tarball: the path segment after the URL's last
@\'\/\'@ (the whole string when it has none), or the conventional
@\<version\>.tgz@ form as a fallback when that segment is empty (a URL ending in
a slash).
-}
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
unVersion Version
version Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".tgz") (Text -> Maybe Text
lastPathSegment Text
url)

{- Project the @dist-tags@ map (tag to raw version string) into a map of tag
to parsed 'Version'.
-}
projectDistTags :: WirePackument -> Map Text Version
projectDistTags :: WirePackument -> Map Text Version
projectDistTags = (Text -> Version) -> Map Text Text -> Map Text Version
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Ecosystem -> Text -> Version
mkVersion Ecosystem
Npm) (Map Text Text -> Map Text Version)
-> (WirePackument -> Map Text Text)
-> WirePackument
-> Map Text Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WirePackument -> Map Text Text
wpDistTags

{- | Parse an npm package name into the domain 'PackageName', splitting a scoped
@\@scope\/name@ into its 'Scope' and bare name. Fails with a 'ParseError' on an
empty name; a non-scoped or well-formed scoped name always succeeds.

This is the npm name canonicaliser: equality on the resulting 'PackageName' is
ecosystem-aware (npm is case-sensitive), so it is the agreement test both the read
path (an upstream's self-reported @name@ against the request) and the publish path (a
document body's declared @_id@\/@name@\/@versions[].name@ against the URL-path name)
compare against -- never a byte-for-byte string compare, so an encoding variant of the
same name cannot disagree silently.
-}
projectName :: Text -> Either ParseError PackageName
projectName :: Text -> Either ParseError PackageName
projectName Text
raw
    | Text -> Bool
T.null Text
raw = ParseError -> Either ParseError PackageName
forall a b. a -> Either a b
Left (Text -> ParseError
ParseError Text
"empty package name")
    | Bool
otherwise = case Text -> Maybe (Scope, Text)
scopeOf Text
raw of
        Just (Scope
scope, Text
base) -> PackageName -> Either ParseError PackageName
forall a b. b -> Either a b
Right (Ecosystem -> Maybe Scope -> Text -> PackageName
mkPackageName Ecosystem
Npm (Scope -> Maybe Scope
forall a. a -> Maybe a
Just Scope
scope) Text
base)
        Maybe (Scope, Text)
Nothing -> PackageName -> Either ParseError PackageName
forall a b. b -> Either a b
Right (Ecosystem -> Maybe Scope -> Text -> PackageName
mkPackageName Ecosystem
Npm Maybe Scope
forall a. Maybe a
Nothing Text
raw)

{- Split a scoped npm name @\@scope\/name@ into its 'Scope' and bare name, or
'Nothing' for an unscoped name. An @\'\@\'@-prefixed name with no @\'\/\'@, an
empty scope, or an empty bare name are all malformed and yield 'Nothing' (the
caller then treats the whole string as an unscoped name).
-}
scopeOf :: Text -> Maybe (Scope, Text)
scopeOf :: Text -> Maybe (Scope, Text)
scopeOf Text
raw = do
    afterAt <- Text -> Text -> Maybe Text
T.stripPrefix Text
"@" Text
raw
    let (scopeText, rest) = T.break (== '/') afterAt
        base = Int -> Text -> Text
T.drop Int
1 Text
rest
    guard (not (T.null scopeText))
    guard (not (T.null base))
    pure (mkScope scopeText, base)

-- Project a wire 'Wire.Person' into the domain 'Person' (a structural copy).
projectPerson :: Wire.Person -> Person
projectPerson :: Person -> Person
projectPerson Person
p =
    Person
        { personName :: Text
personName = Person -> Text
Wire.personName Person
p
        , personEmail :: Maybe Text
personEmail = Person -> Maybe Text
Wire.personEmail Person
p
        , personUrl :: Maybe Text
personUrl = Person -> Maybe Text
Wire.personUrl Person
p
        }