{- | 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
    parsePackageInfo,
    parsePackageInfoFromValue,
    parseVersionDetails,
    parseVersionList,
    projectVersionEntry,

    -- * Egress-scheme normalisation
    enforceTarballScheme,
    enforceTarballSchemeDetails,

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

import Data.Aeson (FromJSON (parseJSON), Object, Value (String), 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, SRI),
    InvalidEntry (..),
    InvalidEntryKind (InvalidDistTag, InvalidPublishTime, InvalidVersionManifest),
    PackageDetails (..),
    PackageInfo (..),
    PackageName,
    Person (..),
    Scope,
    Trust (TrustUnknown),
    mkHash,
    mkPackageName,
    mkScope,
    renderPackageName,
 )
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.Security (hostAddress)
import Ecluse.Core.Security.Egress (registryUrlText, resolveTarballUrl)
import Ecluse.Core.Version (Version, mkVersion, renderVersion, 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 reusing the wire
'Wire.Packument') 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
                }

{- Partition a raw @key -> 'Value'@ map into the entries that decode and the ones that
do not: each undecodable entry is dropped and recorded as an 'InvalidEntry' of the given
'InvalidEntryKind', carrying its key, the __raw offending 'Value'__ (verbatim, for
diagnostics), and the aeson decode error as the reason. The dropped list is in
ascending-key order ('Map.foldrWithKey' visits keys ascending and each step prepends), so
it is deterministic. This is the one place per-entry leniency and drop-tracking are
realised, shared by the @dist-tags@\/@time@ axes (the @versions@ axis layers a domain
decode on top). -}
partitionLenient :: InvalidEntryKind -> (Value -> Either String a) -> Map Text Value -> (Map Text a, [InvalidEntry])
partitionLenient :: forall a.
InvalidEntryKind
-> (Value -> Either String a)
-> Map Text Value
-> (Map Text a, [InvalidEntry])
partitionLenient InvalidEntryKind
kind Value -> Either String a
decode =
    (Text
 -> Value
 -> (Map Text a, [InvalidEntry])
 -> (Map Text a, [InvalidEntry]))
-> (Map Text a, [InvalidEntry])
-> Map Text Value
-> (Map Text a, [InvalidEntry])
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Text
-> Value
-> (Map Text a, [InvalidEntry])
-> (Map Text a, [InvalidEntry])
step (Map Text a
forall k a. Map k a
Map.empty, [])
  where
    step :: Text
-> Value
-> (Map Text a, [InvalidEntry])
-> (Map Text a, [InvalidEntry])
step Text
key Value
value (Map Text a
kept, [InvalidEntry]
dropped) = case Value -> Either String a
decode Value
value of
        Right a
a -> (Text -> a -> Map Text a -> Map Text a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
key a
a Map Text a
kept, [InvalidEntry]
dropped)
        Left String
err -> (Map Text a
kept, InvalidEntryKind -> Text -> Value -> Text -> InvalidEntry
InvalidEntry InvalidEntryKind
kind Text
key Value
value (String -> Text
forall a. ToText a => a -> Text
toText String
err) InvalidEntry -> [InvalidEntry] -> [InvalidEntry]
forall a. a -> [a] -> [a]
: [InvalidEntry]
dropped)

{- 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 a fetched metadata response into the packument-level 'PackageInfo' for
the requested package. Pure and total: a body that is not a decodable npm packument
is reported as a 'ParseError', never thrown.

The requested name is the validation authority. A document whose self-reported name
__disagrees__ with the request cannot yield a valid view of the requested package,
so it is reported as a 'ParseError' here -- the typed-view accessor admits only a
matching document. The finer 'Projection' (a mismatch distinguished from a decode
failure) is surfaced by 'parsePackageInfoFromValue', which the serve layer uses to
distinguish a misreporting origin from an undecodable one.
-}
parsePackageInfo :: PackageName -> RegistryResponse -> Either ParseError PackageInfo
parsePackageInfo :: PackageName -> RegistryResponse -> Either ParseError PackageInfo
parsePackageInfo PackageName
requestedName RegistryResponse
resp =
    RegistryResponse -> Either ParseError WirePackument
decodePackument RegistryResponse
resp 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 Either ParseError Projection
-> (Projection -> Either ParseError PackageInfo)
-> Either ParseError PackageInfo
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
>>= Projection -> Either ParseError PackageInfo
requireMatch

{- | 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 compared to the request via 'PackageName' equality -- ecosystem-
aware, so npm's case sensitivity is honoured. Equal yields 'Projected' carrying the
genuine 'PackageInfo'; unequal yields '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 $
        if infoName info == requestedName
            then Projected info
            else NameMismatch (renderPackageName (infoName info))

{- Collapse a 'Projection' to the typed view the handle's @parsePackageInfo@ field
returns: a match is the 'PackageInfo'; a mismatch is a 'ParseError', because the
typed-view accessor cannot yield a valid view of the requested package from a
document that is for a different one. -}
requireMatch :: Projection -> Either ParseError PackageInfo
requireMatch :: Projection -> Either ParseError PackageInfo
requireMatch = \case
    Projected PackageInfo
info -> PackageInfo -> Either ParseError PackageInfo
forall a b. b -> Either a b
Right PackageInfo
info
    NameMismatch Text
reported ->
        ParseError -> Either ParseError PackageInfo
forall a b. a -> Either a b
Left (Text -> ParseError
ParseError (Text
"upstream packument self-reported the name " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reported Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", which is not the requested package"))

-- 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 fetched metadata response into the 'PackageDetails' for a single
version. Fails with a 'ParseError' if the body does not decode or the requested
version is absent from the packument.
-}
parseVersionDetails :: RegistryResponse -> Version -> Either ParseError PackageDetails
parseVersionDetails :: RegistryResponse -> Version -> Either ParseError PackageDetails
parseVersionDetails RegistryResponse
resp Version
version = do
    info <- RegistryResponse -> Either ParseError WirePackument
decodePackument RegistryResponse
resp Either ParseError WirePackument
-> (WirePackument -> Either ParseError PackageInfo)
-> Either ParseError PackageInfo
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
>>= WirePackument -> Either ParseError PackageInfo
projectPackageInfo
    case Map.lookup (renderVersion version) (infoVersions info) of
        Just PackageDetails
details -> PackageDetails -> Either ParseError PackageDetails
forall a b. b -> Either a b
Right PackageDetails
details
        Maybe PackageDetails
Nothing ->
            ParseError -> Either ParseError PackageDetails
forall a b. a -> Either a b
Left (Text -> ParseError
ParseError (Text
"version not present in packument: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
renderVersion Version
version))

{- | 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
'parsePackageInfo'. 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

{- | Normalise every served version's @dist.tarball@ scheme against the https-only
egress policy ('Ecluse.Core.Security.Egress.resolveTarballUrl'), given the
@upstreamBaseUrl@ the packument was served from. An https tarball is kept, a same-host
@http@ tarball is __upgraded__ to https, and a version whose tarball is @http@ on a
foreign host (or any non-http(s) URL) is __dropped__ from the served set and recorded as
an 'Ecluse.Core.Package.InvalidVersionManifest' carrying the offending URL (the #486
drop-and-record contract), so the version is never dialled in plaintext and the drop is
observable.

The enforcement applies only when the upstream is __https__ (in production every
configured upstream is https by construction). A non-https upstream is the test\/dev
loopback opt-in, whose tarballs are left untouched. Applied as a projection post-step at
the fetch boundary, where the upstream URL is known, so the projection stays context-free.
-}
enforceTarballScheme :: Text -> PackageInfo -> PackageInfo
enforceTarballScheme :: Text -> PackageInfo -> PackageInfo
enforceTarballScheme Text
upstreamBaseUrl PackageInfo
info =
    case Text -> Maybe Text
httpsUpstreamHost Text
upstreamBaseUrl of
        Maybe Text
Nothing -> PackageInfo
info
        Just Text
upstreamHost ->
            let (Map Text PackageDetails
kept, [InvalidEntry]
drops) = (Text
 -> PackageDetails
 -> (Map Text PackageDetails, [InvalidEntry])
 -> (Map Text PackageDetails, [InvalidEntry]))
-> (Map Text PackageDetails, [InvalidEntry])
-> Map Text PackageDetails
-> (Map Text PackageDetails, [InvalidEntry])
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (Text
-> Text
-> PackageDetails
-> (Map Text PackageDetails, [InvalidEntry])
-> (Map Text PackageDetails, [InvalidEntry])
step Text
upstreamHost) (Map Text PackageDetails
forall k a. Map k a
Map.empty, []) (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info)
             in PackageInfo
info{infoVersions = kept, infoInvalidEntries = infoInvalidEntries info <> drops}
  where
    step :: Text
-> Text
-> PackageDetails
-> (Map Text PackageDetails, [InvalidEntry])
-> (Map Text PackageDetails, [InvalidEntry])
step Text
upstreamHost Text
rawVersion PackageDetails
details (Map Text PackageDetails
keptAcc, [InvalidEntry]
dropAcc) =
        case Text -> PackageDetails -> Either (Text, Text) PackageDetails
resolveDetails Text
upstreamHost PackageDetails
details of
            Right PackageDetails
ok -> (Text
-> PackageDetails
-> Map Text PackageDetails
-> Map Text PackageDetails
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
rawVersion PackageDetails
ok Map Text PackageDetails
keptAcc, [InvalidEntry]
dropAcc)
            Left (Text
reason, Text
badUrl) ->
                (Map Text PackageDetails
keptAcc, InvalidEntryKind -> Text -> Value -> Text -> InvalidEntry
InvalidEntry InvalidEntryKind
InvalidVersionManifest Text
rawVersion (Text -> Value
String Text
badUrl) Text
reason InvalidEntry -> [InvalidEntry] -> [InvalidEntry]
forall a. a -> [a] -> [a]
: [InvalidEntry]
dropAcc)

{- | The single-version form of 'enforceTarballScheme' for the selective decode path:
'Nothing' drops the version (its @dist.tarball@ is non-https and not upgradeable), a
'Just' carries the version with each artifact's URL normalised to https. A non-https
(test\/dev loopback) upstream leaves the version untouched.
-}
enforceTarballSchemeDetails :: Text -> PackageDetails -> Maybe PackageDetails
enforceTarballSchemeDetails :: Text -> PackageDetails -> Maybe PackageDetails
enforceTarballSchemeDetails Text
upstreamBaseUrl PackageDetails
details =
    case Text -> Maybe Text
httpsUpstreamHost Text
upstreamBaseUrl of
        Maybe Text
Nothing -> PackageDetails -> Maybe PackageDetails
forall a. a -> Maybe a
Just PackageDetails
details
        Just Text
upstreamHost -> Either (Text, Text) PackageDetails -> Maybe PackageDetails
forall l r. Either l r -> Maybe r
rightToMaybe (Text -> PackageDetails -> Either (Text, Text) PackageDetails
resolveDetails Text
upstreamHost PackageDetails
details)

-- The bare host of an @https@ upstream base URL, or 'Nothing' for a non-https (test/dev
-- loopback) upstream whose tarballs the scheme enforcement leaves untouched.
httpsUpstreamHost :: Text -> Maybe Text
httpsUpstreamHost :: Text -> Maybe Text
httpsUpstreamHost Text
baseUrl
    | Text
"https://" Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
T.toLower Text
baseUrl = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
hostAddress Text
baseUrl)
    | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing

-- Resolve every artifact of a version against the egress policy: 'Right' the version
-- with each @artUrl@ normalised to https, or 'Left' the drop reason and the first
-- offending URL.
resolveDetails :: Text -> PackageDetails -> Either (Text, Text) PackageDetails
resolveDetails :: Text -> PackageDetails -> Either (Text, Text) PackageDetails
resolveDetails Text
upstreamHost PackageDetails
details =
    (\NonEmpty Artifact
arts -> PackageDetails
details{pkgArtifacts = arts}) (NonEmpty Artifact -> PackageDetails)
-> Either (Text, Text) (NonEmpty Artifact)
-> Either (Text, Text) PackageDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Artifact -> Either (Text, Text) Artifact)
-> NonEmpty Artifact -> Either (Text, Text) (NonEmpty Artifact)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (Text -> Artifact -> Either (Text, Text) Artifact
resolveArtifact Text
upstreamHost) (PackageDetails -> NonEmpty Artifact
pkgArtifacts PackageDetails
details)

-- Normalise one artifact's URL: keep https, upgrade a same-host http, drop otherwise.
resolveArtifact :: Text -> Artifact -> Either (Text, Text) Artifact
resolveArtifact :: Text -> Artifact -> Either (Text, Text) Artifact
resolveArtifact Text
upstreamHost Artifact
art =
    case Text -> Text -> Either Text RegistryUrl
resolveTarballUrl Text
upstreamHost (Artifact -> Text
artUrl Artifact
art) of
        Right RegistryUrl
resolved -> Artifact -> Either (Text, Text) Artifact
forall a b. b -> Either a b
Right Artifact
art{artUrl = registryUrlText resolved}
        Left Text
reason -> (Text, Text) -> Either (Text, Text) Artifact
forall a b. a -> Either a b
Left (Text
reason, Artifact -> Text
artUrl Artifact
art)

{- | 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 'enforceTarballScheme'.
-}
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 = [Maybe Hash] -> [Hash]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Hash
sriHash, 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
    sriHash :: Maybe Hash
sriHash = Dist -> Maybe Text
distIntegrity 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
SRI
    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 =
    let afterLastSlash :: Text
afterLastSlash = (Text, Text) -> Text
forall a b. (a, b) -> b
snd (HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"/" Text
url)
     in if Text -> Bool
T.null Text
afterLastSlash then Version -> Text
unVersion Version
version Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".tgz" else Text
afterLastSlash

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