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

{- | Join streamed npm versions, tags and timestamps without retaining the source document. The typed
projection keeps each release's typed facts, and each read keeps the served releases in its own form:
aeson's tree, or packed against the read's table.
-}
module Ecluse.Core.Registry.Npm.StreamingProjection (
    -- * Typed facts
    NpmProjection,
    TypedRelease,
    emptyProjection,
    keepsRelease,
    collectField,

    -- * Reading releases as aeson's tree
    TreeRead,
    emptyTreeRead,
    keepsTreeRelease,
    treeStep,
    finishTree,

    -- * Reading releases packed
    PackedRead,
    emptyPackedRead,
    keepsPackedRelease,
    packedStep,
    finishPacked,
) where

import Control.Monad.ST (ST)
import Data.Aeson (Value (..), parseJSON)
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (parseEither)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Time (UTCTime)

import Ecluse.Core.Ecosystem (Ecosystem (Npm))
import Ecluse.Core.Package (InvalidEntry, InvalidEntryKind (..), PackageDetails (..), PackageInfo (..), PackageName, mkInvalidEntry)
import Ecluse.Core.Registry.Json.Packed (DocTable, Packed, withoutHole)
import Ecluse.Core.Registry.Json.Writer (Pick (..), Writer, decodePicked, decodeWhole, discard, replacedMember, sealValue)
import Ecluse.Core.Registry.Metadata (MetadataError (..))
import Ecluse.Core.Registry.Metadata.Projection (projectionResult, validateReportedName)
import Ecluse.Core.Registry.Npm.Document (PackedPackument (..), tarballHole, tarballUrl)
import Ecluse.Core.Registry.Npm.Project (projectName, projectVersionEntryResult)
import Ecluse.Core.Registry.Npm.Streaming (NpmContainer (..), NpmFieldOf (..), versionListFields)
import Ecluse.Core.Registry.Npm.Wire (distFields)
import Ecluse.Core.Registry.ServedDocument (rebaseArtifactUrl)
import Ecluse.Core.Registry.WireSupport (checkNameAgreement)
import Ecluse.Core.Security (LimitError, Limits, checkArtifactCount, checkVersionCountOf)
import Ecluse.Core.Strict (strictElements)
import Ecluse.Core.Version (Version, mkVersion)

-- | A kept release's typed facts, or the entry that records why it was dropped.
type TypedRelease = Either InvalidEntry PackageDetails

-- | Independent source maps. Typed releases are built as each retained version finishes.
data NpmProjection = NpmProjection
    { NpmProjection -> Maybe Value
projectedName :: Maybe Value
    , NpmProjection -> Map Text TypedRelease
projectedVersions :: Map Text TypedRelease
    , NpmProjection -> Map Text (Either InvalidEntry UTCTime)
projectedTimes :: Map Text (Either InvalidEntry UTCTime)
    , NpmProjection -> Map Text (Either InvalidEntry Version)
projectedTags :: Map Text (Either InvalidEntry Version)
    , NpmProjection -> Map Text Value
projectedBookkeeping :: Map Text Value
    , NpmProjection -> Int
projectedCount :: Int
    , NpmProjection -> Set NpmContainer
projectedContainers :: Set NpmContainer
    , NpmProjection -> Maybe NpmContainer
projectedActiveContainer :: Maybe NpmContainer
    , NpmProjection -> Bool
projectedInvalidContainer :: Bool
    }

-- | Start one source projection. No document or input chunk is retained here.
emptyProjection :: NpmProjection
emptyProjection :: NpmProjection
emptyProjection =
    NpmProjection
        { projectedName :: Maybe Value
projectedName = Maybe Value
forall a. Maybe a
Nothing
        , projectedVersions :: Map Text TypedRelease
projectedVersions = Map Text TypedRelease
forall a. Monoid a => a
mempty
        , projectedTimes :: Map Text (Either InvalidEntry UTCTime)
projectedTimes = Map Text (Either InvalidEntry UTCTime)
forall a. Monoid a => a
mempty
        , projectedTags :: Map Text (Either InvalidEntry Version)
projectedTags = Map Text (Either InvalidEntry Version)
forall a. Monoid a => a
mempty
        , projectedBookkeeping :: Map Text Value
projectedBookkeeping = Map Text Value
forall a. Monoid a => a
mempty
        , projectedCount :: Int
projectedCount = Int
0
        , projectedContainers :: Set NpmContainer
projectedContainers = Set NpmContainer
forall a. Monoid a => a
mempty
        , projectedActiveContainer :: Maybe NpmContainer
projectedActiveContainer = Maybe NpmContainer
forall a. Maybe a
Nothing
        , projectedInvalidContainer :: Bool
projectedInvalidContainer = Bool
False
        }

-- | Whether a release read now under the key would be kept: the key's first in the first versions object.
keepsRelease :: NpmProjection -> Text -> Bool
keepsRelease :: NpmProjection -> Text -> Bool
keepsRelease NpmProjection
acc Text
key = NpmProjection -> Maybe NpmContainer
projectedActiveContainer NpmProjection
acc Maybe NpmContainer -> Maybe NpmContainer -> Bool
forall a. Eq a => a -> a -> Bool
== NpmContainer -> Maybe NpmContainer
forall a. a -> Maybe a
Just NpmContainer
VersionsContainer Bool -> Bool -> Bool
&& Text -> Map Text TypedRelease -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Text
key (NpmProjection -> Map Text TypedRelease
projectedVersions NpmProjection
acc)

-- Receive a release the projection keeps, with its typed facts, and enforce the version ceiling.
collectRelease :: Limits -> NpmProjection -> NpmFieldOf release -> Text -> TypedRelease -> Either LimitError NpmProjection
collectRelease :: forall release.
Limits
-> NpmProjection
-> NpmFieldOf release
-> Text
-> TypedRelease
-> Either LimitError NpmProjection
collectRelease Limits
limits NpmProjection
acc NpmFieldOf release
field Text
key TypedRelease
typed = (\NpmProjection
counted -> NpmProjection
counted{projectedVersions = Map.insert key typed (projectedVersions counted)}) (NpmProjection -> NpmProjection)
-> Either LimitError NpmProjection
-> Either LimitError NpmProjection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Limits
-> NpmProjection
-> NpmFieldOf release
-> Either LimitError NpmProjection
forall release.
Limits
-> NpmProjection
-> NpmFieldOf release
-> Either LimitError NpmProjection
collectField Limits
limits NpmProjection
acc NpmFieldOf release
field

-- | Enforce the version ceiling while receiving source fields. A release's own payload is not read here.
collectField :: Limits -> NpmProjection -> NpmFieldOf release -> Either LimitError NpmProjection
collectField :: forall release.
Limits
-> NpmProjection
-> NpmFieldOf release
-> Either LimitError NpmProjection
collectField Limits
limits NpmProjection
acc = \case
    NpmFieldOf release
IgnoredField -> NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right NpmProjection
acc{projectedActiveContainer = Nothing}
    BeginContainer NpmContainer
container ->
        NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right
            NpmProjection
acc
                { projectedContainers = Set.insert container (projectedContainers acc)
                , projectedActiveContainer = if Set.member container (projectedContainers acc) then Nothing else Just container
                }
    InvalidContainer NpmContainer
container ->
        NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right
            NpmProjection
acc
                { projectedContainers = Set.insert container (projectedContainers acc)
                , projectedActiveContainer = Nothing
                , projectedInvalidContainer = projectedInvalidContainer acc || Set.notMember container (projectedContainers acc)
                }
    NameField Value
value -> NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right NpmProjection
acc{projectedName = projectedName acc <|> Just value}
    VersionField Text
_ Maybe release
_ | NpmProjection -> Maybe NpmContainer
projectedActiveContainer NpmProjection
acc Maybe NpmContainer -> Maybe NpmContainer -> Bool
forall a. Eq a => a -> a -> Bool
/= NpmContainer -> Maybe NpmContainer
forall a. a -> Maybe a
Just NpmContainer
VersionsContainer -> NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right NpmProjection
acc
    VersionField Text
_ Maybe release
_ -> do
        let count :: Int
count = NpmProjection -> Int
projectedCount NpmProjection
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        Limits -> Int -> Either LimitError ()
checkVersionCountOf Limits
limits Int
count
        NpmProjection -> Either LimitError NpmProjection
forall a. a -> Either LimitError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NpmProjection
acc{projectedCount = count}
    TimeField Text
_ Value
_ | NpmProjection -> Maybe NpmContainer
projectedActiveContainer NpmProjection
acc Maybe NpmContainer -> Maybe NpmContainer -> Bool
forall a. Eq a => a -> a -> Bool
/= NpmContainer -> Maybe NpmContainer
forall a. a -> Maybe a
Just NpmContainer
TimeContainer -> NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right NpmProjection
acc
    TimeField Text
key Value
_ | Text -> Map Text (Either InvalidEntry UTCTime) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Text
key (NpmProjection -> Map Text (Either InvalidEntry UTCTime)
projectedTimes NpmProjection
acc) -> NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right NpmProjection
acc
    TimeField Text
key Value
value ->
        NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right
            NpmProjection
acc
                { projectedTimes = firstInsert key (decode force InvalidPublishTime key value) (projectedTimes acc)
                , projectedBookkeeping =
                    if key == "created" || key == "modified"
                        then firstInsert key value (projectedBookkeeping acc)
                        else projectedBookkeeping acc
                }
    TagField Text
_ Value
_ | NpmProjection -> Maybe NpmContainer
projectedActiveContainer NpmProjection
acc Maybe NpmContainer -> Maybe NpmContainer -> Bool
forall a. Eq a => a -> a -> Bool
/= NpmContainer -> Maybe NpmContainer
forall a. a -> Maybe a
Just NpmContainer
TagsContainer -> NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right NpmProjection
acc
    TagField Text
key Value
_ | Text -> Map Text (Either InvalidEntry Version) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Text
key (NpmProjection -> Map Text (Either InvalidEntry Version)
projectedTags NpmProjection
acc) -> NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right NpmProjection
acc
    TagField Text
key Value
value -> NpmProjection -> Either LimitError NpmProjection
forall a b. b -> Either a b
Right NpmProjection
acc{projectedTags = firstInsert key (decode (mkVersion Npm) InvalidDistTag key value) (projectedTags acc)}
  where
    -- Force the decoded payload so a successful entry cannot retain its source Value.
    decode :: (t -> b)
-> InvalidEntryKind -> Text -> Value -> Either InvalidEntry b
decode t -> b
convert InvalidEntryKind
kind Text
key Value
value = case (Value -> Parser t) -> Value -> Either String t
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser t
forall a. FromJSON a => Value -> Parser a
parseJSON Value
value of
        Left String
err -> InvalidEntry -> Either InvalidEntry b
forall a b. a -> Either a b
Left (InvalidEntry -> Either InvalidEntry b)
-> InvalidEntry -> Either InvalidEntry b
forall a b. (a -> b) -> a -> b
$! InvalidEntryKind -> Text -> Value -> Text -> InvalidEntry
mkInvalidEntry InvalidEntryKind
kind Text
key Value
value (String -> Text
forall a. ToText a => a -> Text
toText String
err)
        Right t
typed -> b -> Either InvalidEntry b
forall a b. b -> Either a b
Right (b -> Either InvalidEntry b) -> b -> Either InvalidEntry b
forall a b. (a -> b) -> a -> b
$! t -> b
convert t
typed

firstInsert :: (Ord k) => k -> a -> Map k a -> Map k a
firstInsert :: forall k a. Ord k => k -> a -> Map k a -> Map k a
firstInsert = (a -> a -> a) -> k -> a -> Map k a -> Map k a
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\a
_ a
old -> a
old)

-- A release's typed facts from the members they read, or why it does not project.
projectRelease :: PackageName -> Text -> Value -> Either Text PackageDetails
projectRelease :: PackageName -> Text -> Value -> Either Text PackageDetails
projectRelease PackageName
name Text
key Value
projected = case PackageName
-> Version
-> Maybe UTCTime
-> Value
-> Either String PackageDetails
projectVersionEntryResult PackageName
name (Ecosystem -> Text -> Version
mkVersion Ecosystem
Npm Text
key) Maybe UTCTime
forall a. Maybe a
Nothing Value
projected of
    Left String
err -> Text -> Either Text PackageDetails
forall a b. a -> Either a b
Left (String -> Text
forall a. ToText a => a -> Text
toText String
err)
    Right PackageDetails
details -> PackageDetails -> Either Text PackageDetails
forall a b. b -> Either a b
Right (PackageDetails -> Either Text PackageDetails)
-> PackageDetails -> Either Text PackageDetails
forall a b. (a -> b) -> a -> b
$! PackageDetails
details

-- A dropped release, recorded with the whole release as read.
invalidRelease :: Text -> Value -> Text -> TypedRelease
invalidRelease :: Text -> Value -> Text -> TypedRelease
invalidRelease Text
key Value
whole Text
reason = InvalidEntry -> TypedRelease
forall a b. a -> Either a b
Left (InvalidEntry -> TypedRelease) -> InvalidEntry -> TypedRelease
forall a b. (a -> b) -> a -> b
$! InvalidEntryKind -> Text -> Value -> Text -> InvalidEntry
mkInvalidEntry InvalidEntryKind
InvalidVersionManifest Text
key Value
whole Text
reason

-- The parts a finished read serves beside its releases: the reported name and the bookkeeping times.
data NpmParts = NpmParts Value (Map Text Value)

-- Bind the reported name and join policy timestamps with their same-source releases.
finishParts :: Limits -> PackageName -> NpmProjection -> Either MetadataError (PackageInfo, NpmParts)
finishParts :: Limits
-> PackageName
-> NpmProjection
-> Either MetadataError (PackageInfo, NpmParts)
finishParts Limits
limits PackageName
requested NpmProjection
acc = do
    Bool -> Either MetadataError () -> Either MetadataError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NpmProjection -> Bool
projectedInvalidContainer NpmProjection
acc) (MetadataError -> Either MetadataError ()
forall a b. a -> Either a b
Left MetadataError
MetadataUndecodable)
    reported <- (Text -> Either ParseError PackageName)
-> Maybe Value -> Either MetadataError PackageName
validateReportedName Text -> Either ParseError PackageName
projectName (NpmProjection -> Maybe Value
projectedName NpmProjection
acc)
    _ <- projectionResult (checkNameAgreement requested reported ())
    info <- first MetadataBoundExceeded (checkArtifactCount limits package)
    pure (info, NpmParts (fromMaybe Null (projectedName acc)) (projectedBookkeeping acc))
  where
    versions :: Map Text PackageDetails
versions = (TypedRelease -> Maybe PackageDetails)
-> Map Text TypedRelease -> Map Text PackageDetails
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe TypedRelease -> Maybe PackageDetails
forall l r. Either l r -> Maybe r
rightToMaybe (NpmProjection -> Map Text TypedRelease
projectedVersions NpmProjection
acc)
    times :: Map Text UTCTime
times = (Either InvalidEntry UTCTime -> Maybe UTCTime)
-> Map Text (Either InvalidEntry UTCTime) -> Map Text UTCTime
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Either InvalidEntry UTCTime -> Maybe UTCTime
forall l r. Either l r -> Maybe r
rightToMaybe (NpmProjection -> Map Text (Either InvalidEntry UTCTime)
projectedTimes NpmProjection
acc)
    tags :: Map Text Version
tags = (Either InvalidEntry Version -> Maybe Version)
-> Map Text (Either InvalidEntry Version) -> Map Text Version
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Either InvalidEntry Version -> Maybe Version
forall l r. Either l r -> Maybe r
rightToMaybe (NpmProjection -> Map Text (Either InvalidEntry Version)
projectedTags NpmProjection
acc)
    stamp :: Text -> PackageDetails -> PackageDetails
stamp Text
key PackageDetails
details = PackageDetails
details{pkgPublishedAt = Map.lookup key times}
    drops :: Map k (Either a b) -> [a]
drops = [Either a b] -> [a]
forall a b. [Either a b] -> [a]
lefts ([Either a b] -> [a])
-> (Map k (Either a b) -> [Either a b])
-> Map k (Either a b)
-> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k (Either a b) -> [Either a b]
forall k a. Map k a -> [a]
Map.elems
    package :: PackageInfo
package =
        PackageInfo
            { infoName :: PackageName
infoName = PackageName
requested
            , infoVersions :: Map Text PackageDetails
infoVersions = (Text -> PackageDetails -> PackageDetails)
-> Map Text PackageDetails -> Map Text PackageDetails
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Text -> PackageDetails -> PackageDetails
stamp Map Text PackageDetails
versions
            , infoDistTags :: Map Text Version
infoDistTags = Map Text Version
tags
            , infoInvalidEntries :: [InvalidEntry]
infoInvalidEntries =
                [InvalidEntry] -> [InvalidEntry]
forall (t :: * -> *) a. Foldable t => t a -> t a
strictElements
                    ( Map Text TypedRelease -> [InvalidEntry]
forall {k} {a} {b}. Map k (Either a b) -> [a]
drops (NpmProjection -> Map Text TypedRelease
projectedVersions NpmProjection
acc)
                        [InvalidEntry] -> [InvalidEntry] -> [InvalidEntry]
forall a. Semigroup a => a -> a -> a
<> Map Text (Either InvalidEntry Version) -> [InvalidEntry]
forall {k} {a} {b}. Map k (Either a b) -> [a]
drops (NpmProjection -> Map Text (Either InvalidEntry Version)
projectedTags NpmProjection
acc)
                        [InvalidEntry] -> [InvalidEntry] -> [InvalidEntry]
forall a. Semigroup a => a -> a -> a
<> Map Text (Either InvalidEntry UTCTime) -> [InvalidEntry]
forall {k} {a} {b}. Map k (Either a b) -> [a]
drops (Map Text (Either InvalidEntry UTCTime)
-> Set Text -> Map Text (Either InvalidEntry UTCTime)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (NpmProjection -> Map Text (Either InvalidEntry UTCTime)
projectedTimes NpmProjection
acc) (Map Text PackageDetails -> Set Text
forall k a. Map k a -> Set k
Map.keysSet Map Text PackageDetails
versions))
                    )
            }

-- | A read that keeps each release as aeson's tree: the typed facts, and the served releases.
data TreeRead = TreeRead NpmProjection (Map Text Value)

-- | Start a tree read.
emptyTreeRead :: TreeRead
emptyTreeRead :: TreeRead
emptyTreeRead = NpmProjection -> Map Text Value -> TreeRead
TreeRead NpmProjection
emptyProjection Map Text Value
forall a. Monoid a => a
mempty

-- | Whether the tree read keeps a release read now under the key.
keepsTreeRelease :: TreeRead -> Text -> Bool
keepsTreeRelease :: TreeRead -> Text -> Bool
keepsTreeRelease (TreeRead NpmProjection
acc Map Text Value
_) = NpmProjection -> Text -> Bool
keepsRelease NpmProjection
acc

-- | Project each kept release from its tree, and serve the tree as read.
treeStep :: Limits -> PackageName -> TreeRead -> NpmFieldOf Value -> Either LimitError TreeRead
treeStep :: Limits
-> PackageName
-> TreeRead
-> NpmFieldOf Value
-> Either LimitError TreeRead
treeStep Limits
limits PackageName
name (TreeRead NpmProjection
acc Map Text Value
served) NpmFieldOf Value
field = case NpmFieldOf Value
field of
    VersionField Text
key (Just Value
value) | NpmProjection -> Text -> Bool
keepsRelease NpmProjection
acc Text
key -> do
        let !typed :: TypedRelease
typed = (Text -> TypedRelease)
-> (PackageDetails -> TypedRelease)
-> Either Text PackageDetails
-> TypedRelease
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Value -> Text -> TypedRelease
invalidRelease Text
key Value
value) PackageDetails -> TypedRelease
forall a b. b -> Either a b
Right (PackageName -> Text -> Value -> Either Text PackageDetails
projectRelease PackageName
name Text
key Value
value)
        kept <- Limits
-> NpmProjection
-> NpmFieldOf Value
-> Text
-> TypedRelease
-> Either LimitError NpmProjection
forall release.
Limits
-> NpmProjection
-> NpmFieldOf release
-> Text
-> TypedRelease
-> Either LimitError NpmProjection
collectRelease Limits
limits NpmProjection
acc NpmFieldOf Value
field Text
key TypedRelease
typed
        pure (TreeRead kept (Map.insert key value served))
    NpmFieldOf Value
_ -> (NpmProjection -> Map Text Value -> TreeRead
`TreeRead` Map Text Value
served) (NpmProjection -> TreeRead)
-> Either LimitError NpmProjection -> Either LimitError TreeRead
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Limits
-> NpmProjection
-> NpmFieldOf Value
-> Either LimitError NpmProjection
forall release.
Limits
-> NpmProjection
-> NpmFieldOf release
-> Either LimitError NpmProjection
collectField Limits
limits NpmProjection
acc NpmFieldOf Value
field

-- | Bind the reported name, and serve each kept release with the source author pointer.
finishTree :: Limits -> PackageName -> Text -> TreeRead -> Either MetadataError (PackageInfo, Value)
finishTree :: Limits
-> PackageName
-> Text
-> TreeRead
-> Either MetadataError (PackageInfo, Value)
finishTree Limits
limits PackageName
requested Text
authorPointer (TreeRead NpmProjection
acc Map Text Value
served) = (NpmParts -> Value)
-> (PackageInfo, NpmParts) -> (PackageInfo, Value)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second NpmParts -> Value
document ((PackageInfo, NpmParts) -> (PackageInfo, Value))
-> Either MetadataError (PackageInfo, NpmParts)
-> Either MetadataError (PackageInfo, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Limits
-> PackageName
-> NpmProjection
-> Either MetadataError (PackageInfo, NpmParts)
finishParts Limits
limits PackageName
requested NpmProjection
acc
  where
    document :: NpmParts -> Value
document (NpmParts Value
name Map Text Value
time) =
        Object -> Value
Object
            ( [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList
                [ (Key
"name", Value
name)
                , (Key
"author", Text -> Value
String Text
authorPointer)
                , (Key
"versions", Object -> Value
Object ([(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Text -> Key
Key.fromText Text
key, Value -> Value
withPointer Value
raw) | (Text
key, Value
raw) <- Map Text Value -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text Value
served]))
                , (Key
"time", Object -> Value
Object ([(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Text -> Key
Key.fromText Text
key, Value
raw) | (Text
key, Value
raw) <- Map Text Value -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text Value
time]))
                ]
            )
    withPointer :: Value -> Value
withPointer = \case
        Object Object
fields -> Object -> Value
Object (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"author" (Text -> Value
String Text
authorPointer) Object
fields)
        Value
other -> Value
other

-- | A read that keeps each release packed against its table: the typed facts, and the served releases, latest first.
data PackedRead = PackedRead NpmProjection [(Text, Packed)]

-- | Start a packed read.
emptyPackedRead :: PackedRead
emptyPackedRead :: PackedRead
emptyPackedRead = NpmProjection -> [(Text, Packed)] -> PackedRead
PackedRead NpmProjection
emptyProjection []

-- | Whether the packed read keeps a release read now under the key.
keepsPackedRelease :: PackedRead -> Text -> Bool
keepsPackedRelease :: PackedRead -> Text -> Bool
keepsPackedRelease (PackedRead NpmProjection
acc [(Text, Packed)]
_) = NpmProjection -> Text -> Bool
keepsRelease NpmProjection
acc

{- | Seal each kept release the writer finished, and project its typed facts from the members they
read. A release the read does not keep is discarded.
-}
packedStep :: Writer st -> Limits -> PackageName -> PackedRead -> NpmFieldOf () -> (Either LimitError PackedRead -> ST st r) -> ST st r
packedStep :: forall st r.
Writer st
-> Limits
-> PackageName
-> PackedRead
-> NpmFieldOf ()
-> (Either LimitError PackedRead -> ST st r)
-> ST st r
packedStep Writer st
writer Limits
limits PackageName
name (PackedRead NpmProjection
acc [(Text, Packed)]
served) NpmFieldOf ()
field Either LimitError PackedRead -> ST st r
next = case NpmFieldOf ()
field of
    VersionField Text
key (Just ())
        | NpmProjection -> Text -> Bool
keepsRelease NpmProjection
acc Text
key -> do
            sealed <- Writer st -> [Text] -> ST st Packed
forall st. Writer st -> [Text] -> ST st Packed
sealValue Writer st
writer [Text]
tarballHole
            picked <- decodePicked writer typedMembers sealed
            typed <- case projectRelease name key picked of
                Right PackageDetails
details -> TypedRelease -> ST st TypedRelease
forall a. a -> ST st a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageDetails -> TypedRelease
forall a b. b -> Either a b
Right PackageDetails
details)
                Left Text
reason -> (\Value
whole Maybe Value
original -> Text -> Value -> Text -> TypedRelease
invalidRelease Text
key (Maybe Value -> Value -> Value
asRead Maybe Value
original Value
whole) Text
reason) (Value -> Maybe Value -> TypedRelease)
-> ST st Value -> ST st (Maybe Value -> TypedRelease)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Writer st -> Packed -> ST st Value
forall st. Writer st -> Packed -> ST st Value
decodeWhole Writer st
writer Packed
sealed ST st (Maybe Value -> TypedRelease)
-> ST st (Maybe Value) -> ST st TypedRelease
forall a b. ST st (a -> b) -> ST st a -> ST st b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Writer st -> ST st (Maybe Value)
forall st. Writer st -> ST st (Maybe Value)
replacedMember Writer st
writer
            let !release = if Value -> Bool
rebases Value
picked then Packed
sealed else Packed -> Packed
withoutHole Packed
sealed
            next $! do
                kept <- collectRelease limits acc field key typed
                pure (PackedRead kept ((key, release) : served))
        | Bool
otherwise -> Writer st -> ST st ()
forall st. Writer st -> ST st ()
discard Writer st
writer ST st () -> ST st r -> ST st r
forall a b. ST st a -> ST st b -> ST st b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ST st r
unchanged
    NpmFieldOf ()
_ -> ST st r
unchanged
  where
    unchanged :: ST st r
unchanged = Either LimitError PackedRead -> ST st r
next (Either LimitError PackedRead -> ST st r)
-> Either LimitError PackedRead -> ST st r
forall a b. (a -> b) -> a -> b
$! (NpmProjection -> [(Text, Packed)] -> PackedRead
`PackedRead` [(Text, Packed)]
served) (NpmProjection -> PackedRead)
-> Either LimitError NpmProjection -> Either LimitError PackedRead
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Limits
-> NpmProjection
-> NpmFieldOf ()
-> Either LimitError NpmProjection
forall release.
Limits
-> NpmProjection
-> NpmFieldOf release
-> Either LimitError NpmProjection
collectField Limits
limits NpmProjection
acc NpmFieldOf ()
field
    -- The release as the source wrote it: its own author member, or none, in place of the pointer.
    asRead :: Maybe Value -> Value -> Value
asRead Maybe Value
original = \case
        Object Object
fields -> Object -> Value
Object ((Object -> Object)
-> (Value -> Object -> Object) -> Maybe Value -> Object -> Object
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
"author") (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"author") Maybe Value
original Object
fields)
        Value
other -> Value
other

-- Whether the rebase rule rewrites the release's tarball URL, so a render may rebase its hole.
rebases :: Value -> Bool
rebases :: Value -> Bool
rebases Value
release = Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Value -> Maybe Text
tarballUrl Value
release Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> Maybe Text) -> Text -> Maybe Text
rebaseArtifactUrl Text -> Maybe Text
forall a. a -> Maybe a
Just)

-- The members a release's typed facts read: the version list's fields, and of @dist@ what 'Dist' reads.
typedMembers :: Pick
typedMembers :: Pick
typedMembers = [(Text, Pick)] -> Pick
Only [(Text
field, if Text
field Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"dist" then [(Text, Pick)] -> Pick
Only [(Text
member, Pick
Whole) | Text
member <- [Text]
distFields] else Pick
Whole) | Text
field <- [Text]
versionListFields]

-- | Bind the reported name, and serve each kept release packed over the read's sealed table.
finishPacked :: Limits -> PackageName -> Text -> DocTable -> PackedRead -> Either MetadataError (PackageInfo, PackedPackument)
finishPacked :: Limits
-> PackageName
-> Text
-> DocTable
-> PackedRead
-> Either MetadataError (PackageInfo, PackedPackument)
finishPacked Limits
limits PackageName
requested Text
authorPointer DocTable
table (PackedRead NpmProjection
acc [(Text, Packed)]
served) = (NpmParts -> PackedPackument)
-> (PackageInfo, NpmParts) -> (PackageInfo, PackedPackument)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second NpmParts -> PackedPackument
document ((PackageInfo, NpmParts) -> (PackageInfo, PackedPackument))
-> Either MetadataError (PackageInfo, NpmParts)
-> Either MetadataError (PackageInfo, PackedPackument)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Limits
-> PackageName
-> NpmProjection
-> Either MetadataError (PackageInfo, NpmParts)
finishParts Limits
limits PackageName
requested NpmProjection
acc
  where
    document :: NpmParts -> PackedPackument
document (NpmParts Value
name Map Text Value
time) =
        PackedPackument
            { packumentTop :: Object
packumentTop =
                [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList
                    [ (Key
"name", Value
name)
                    , (Key
"author", Text -> Value
String Text
authorPointer)
                    , (Key
"time", Object -> Value
Object ([(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Text -> Key
Key.fromText Text
key, Value
raw) | (Text
key, Value
raw) <- Map Text Value -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text Value
time]))
                    ]
            , packumentTable :: DocTable
packumentTable = DocTable
table
            , packumentVersions :: KeyMap Packed
packumentVersions = Map Key Packed -> KeyMap Packed
forall v. Map Key v -> KeyMap v
KeyMap.fromMap ([(Key, Packed)] -> Map Key Packed
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList [(Text -> Key
Key.fromText Text
key, Packed
release) | (Text
key, Packed
release) <- ((Text, Packed) -> (Text, Packed) -> Ordering)
-> [(Text, Packed)] -> [(Text, Packed)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Text, Packed) -> Text)
-> (Text, Packed) -> (Text, Packed) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Text, Packed) -> Text
forall a b. (a, b) -> a
fst) [(Text, Packed)]
served])
            }