-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
-- The reads specialise here. Full laziness would float each member's rarely taken continuation out
-- of the element's continuation, and every member of a read would allocate it.
{-# OPTIONS_GHC -fno-full-laziness #-}

{- | npm metadata reads for full manifests and selected versions.
Both fetch the full packument because publish-age rules need its @time@ map.
Selective reads materialise only the requested version and timestamp. A version read pairs the
typed projection with the selected version object, which the mirror write republishes.
-}
module Ecluse.Core.Registry.Npm.Metadata (
    -- * Per-request read handle
    newNpmMetadataReads,

    -- * npm full-manifest fetch
    fetchNpmManifest,

    -- * The memory budget
    npmChargeFactors,

    -- * Reading a packument
    readNpmPackument,
    npmPackumentWalk,
    readNpmFull,
    NpmFullRead,
    npmFullWalk,
    npmFullTable,

    -- * Pure projection
    projectNpmStream,
    projectNpmPacked,
    selectNpmRead,
    selectNpmVersionDoc,
) where

import Control.Monad.ST (ST, stToIO)
import Data.Aeson (Value (Object))
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.JsonStream.TokenParser (TokenResult)
import Data.Map.Strict qualified as Map

import Ecluse.Core.Package (InvalidEntry, PackageInfo (..), PackageName, renderPackageName)
import Ecluse.Core.Package.Filter (enforceArtifactLocations, enforceArtifactLocationsOf)
import Ecluse.Core.Registry (FetchFault (FetchUrlUnformable))
import Ecluse.Core.Registry.CachedDocument (CachedDoc, npmCached, npmPacked)
import Ecluse.Core.Registry.Exchange (chargedRead, digestingRead, formThen, withSuccessBody)
import Ecluse.Core.Registry.Json.Intern (InternTable, Interned (..), decodedName, internName, newInternTable, newTableKey, tableTexts)
import Ecluse.Core.Registry.Json.Packed (docTable)
import Ecluse.Core.Registry.Json.Shape (Trees (..))
import Ecluse.Core.Registry.Json.Walk (Step, Steps, Walked (..), pureStep, readJsonWalk, readJsonWalkST)
import Ecluse.Core.Registry.Json.Writer (Writer, newWriter)
import Ecluse.Core.Registry.JsonStream (StreamResult (..))
import Ecluse.Core.Registry.Metadata (Manifest (..), MetadataError (..), VersionDoc (..), VersionRead (..), metadataResponse)
import Ecluse.Core.Registry.Metadata.Projection (streamError)
import Ecluse.Core.Registry.Npm.Document (PackedPackument)
import Ecluse.Core.Registry.Npm.Reader (PackumentRead (..), npmWalk, releaseUniqueFields)
import Ecluse.Core.Registry.Npm.Request (MetadataForm (Full), metadataRequest, npmArtifactHosts, packageUrl)
import Ecluse.Core.Registry.Npm.StreamingProjection (PackedRead, TreeRead, emptyPackedRead, emptyTreeRead, finishPacked, finishTree, keepsPackedRelease, keepsTreeRelease, packedStep, treeStep)
import Ecluse.Core.Registry.Origin (OriginClient (ocChargeFullRead, ocLimits, ocManager, ocToken), OriginFor, originBaseUrl)
import Ecluse.Core.Registry.ServedDocument (objectField)
import Ecluse.Core.Security (AllowedHostPorts, BodyLimit (MetadataBodyLimit), LimitError, Limits (progressFloor), ecosystemArtifactAuthorities, maxMetadataBytes, maxNestingDepth)
import Ecluse.Core.Server.Admission.Types (ChargeFactors (..))
import Ecluse.Core.Server.Metadata (MetadataReads, newMetadataReads)
import Ecluse.Core.Telemetry.Record (MetricsPort)
import Ecluse.Core.Telemetry.Span (TracingPort (spanMetadataDecode, spanMetadataFetch))
import Ecluse.Core.Version (Version, renderVersion)

-- | Bind one origin's npm metadata reads to their observers, leaving the caching policy to the caller.
newNpmMetadataReads ::
    TracingPort ->
    MetricsPort ->
    (PackageName -> MetadataError -> IO ()) ->
    (PackageName -> [InvalidEntry] -> IO ()) ->
    (PackageName -> IO ()) ->
    OriginFor posture ->
    MetadataReads posture
newNpmMetadataReads :: forall posture.
TracingPort
-> MetricsPort
-> (PackageName -> MetadataError -> IO ())
-> (PackageName -> [InvalidEntry] -> IO ())
-> (PackageName -> IO ())
-> OriginFor posture
-> MetadataReads posture
newNpmMetadataReads TracingPort
tracing MetricsPort
metrics PackageName -> MetadataError -> IO ()
logFailure PackageName -> [InvalidEntry] -> IO ()
logInvalid PackageName -> IO ()
logFetch =
    MetricsPort
-> (PackageName -> MetadataError -> IO ())
-> (PackageName -> [InvalidEntry] -> IO ())
-> (PackageName -> IO ())
-> (OriginClient
    -> PackageName -> IO (Either MetadataError Manifest))
-> (OriginClient
    -> PackageName -> Version -> IO (Either MetadataError VersionRead))
-> OriginFor posture
-> MetadataReads posture
forall posture.
MetricsPort
-> (PackageName -> MetadataError -> IO ())
-> (PackageName -> [InvalidEntry] -> IO ())
-> (PackageName -> IO ())
-> (OriginClient
    -> PackageName -> IO (Either MetadataError Manifest))
-> (OriginClient
    -> PackageName -> Version -> IO (Either MetadataError VersionRead))
-> OriginFor posture
-> MetadataReads posture
newMetadataReads MetricsPort
metrics PackageName -> MetadataError -> IO ()
logFailure PackageName -> [InvalidEntry] -> IO ()
logInvalid PackageName -> IO ()
logFetch (TracingPort
-> OriginClient
-> PackageName
-> IO (Either MetadataError Manifest)
fetchNpmManifest TracingPort
tracing) (TracingPort
-> OriginClient
-> PackageName
-> Version
-> IO (Either MetadataError VersionRead)
fetchNpmVersion TracingPort
tracing)

{- | npm's memory charges, above the largest packed read peak per source byte (0.89, react) and
output working set per basis byte of a realistic merge (1.52, @aws-sdk/client-s3) from one step up.
-}
npmChargeFactors :: ChargeFactors
npmChargeFactors :: ChargeFactors
npmChargeFactors = ChargeFactors{cfFullReadPermille :: Int
cfFullReadPermille = Int
2100, cfOutputPermille :: Int
cfOutputPermille = Int
2000}

-- | Fetch compact installation metadata and the complete source digest inside the response lifetime.
fetchNpmManifest :: TracingPort -> OriginClient -> PackageName -> IO (Either MetadataError Manifest)
fetchNpmManifest :: TracingPort
-> OriginClient
-> PackageName
-> IO (Either MetadataError Manifest)
fetchNpmManifest TracingPort
tracing OriginClient
origin PackageName
name = do
    result <- TracingPort
-> OriginClient
-> PackageName
-> (IO ByteString
    -> IO
         (Either LimitError (StreamResult NpmFullRead, ContentDigest)))
-> IO
     (Either MetadataError (StreamResult NpmFullRead, ContentDigest))
forall r.
TracingPort
-> OriginClient
-> PackageName
-> (IO ByteString -> IO (Either LimitError r))
-> IO (Either MetadataError r)
fetchNpmBody TracingPort
tracing OriginClient
origin PackageName
name ((IO ByteString
 -> IO (Either LimitError (StreamResult NpmFullRead)))
-> IO ByteString
-> IO (Either LimitError (StreamResult NpmFullRead, ContentDigest))
forall e a.
(IO ByteString -> IO (Either e a))
-> IO ByteString -> IO (Either e (a, ContentDigest))
digestingRead (TracingPort -> forall a. PackageName -> IO a -> IO a
spanMetadataDecode TracingPort
tracing PackageName
name (IO (Either LimitError (StreamResult NpmFullRead))
 -> IO (Either LimitError (StreamResult NpmFullRead)))
-> (IO ByteString
    -> IO (Either LimitError (StreamResult NpmFullRead)))
-> IO ByteString
-> IO (Either LimitError (StreamResult NpmFullRead))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Limits
-> PackageName
-> Text
-> IO ByteString
-> IO (Either LimitError (StreamResult NpmFullRead))
readNpmFull (OriginClient -> Limits
ocLimits OriginClient
origin) PackageName
name (OriginClient -> Text
originBaseUrl OriginClient
origin)) (IO ByteString
 -> IO
      (Either LimitError (StreamResult NpmFullRead, ContentDigest)))
-> (IO ByteString -> IO ByteString)
-> IO ByteString
-> IO (Either LimitError (StreamResult NpmFullRead, ContentDigest))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IO ()) -> IO ByteString -> IO ByteString
chargedRead (OriginClient -> Int -> IO ()
ocChargeFullRead OriginClient
origin))
    pure $ do
        (streamed, digest) <- result
        (info, packed) <- projectNpmPacked (ocLimits origin) name (originBaseUrl origin) streamed
        pure
            Manifest
                { manifestInfo = enforceArtifactLocations npmArtifactAuthorities (originBaseUrl origin) info
                , manifestRaw = fst npmPacked packed
                , manifestBodyBytes = streamBytes streamed
                , manifestDigest = digest
                }

fetchNpmBody :: TracingPort -> OriginClient -> PackageName -> (IO ByteString -> IO (Either LimitError r)) -> IO (Either MetadataError r)
fetchNpmBody :: forall r.
TracingPort
-> OriginClient
-> PackageName
-> (IO ByteString -> IO (Either LimitError r))
-> IO (Either MetadataError r)
fetchNpmBody TracingPort
tracing OriginClient
origin PackageName
name IO ByteString -> IO (Either LimitError r)
consume =
    Either FetchFault (BodyOutcome r) -> Either MetadataError r
forall a.
Either FetchFault (BodyOutcome a) -> Either MetadataError a
metadataResponse
        (Either FetchFault (BodyOutcome r) -> Either MetadataError r)
-> IO (Either FetchFault (BodyOutcome r))
-> IO (Either MetadataError r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TracingPort -> forall a. PackageName -> IO a -> IO a
spanMetadataFetch
            TracingPort
tracing
            PackageName
name
            ((UrlFormationError -> FetchFault)
-> (Request -> IO (Either FetchFault (BodyOutcome r)))
-> Either UrlFormationError Request
-> IO (Either FetchFault (BodyOutcome r))
forall fault a.
(UrlFormationError -> fault)
-> (Request -> IO (Either fault a))
-> Either UrlFormationError Request
-> IO (Either fault a)
formThen UrlFormationError -> FetchFault
FetchUrlUnformable (Manager
-> ProgressFloor
-> (IO ByteString -> IO (Either LimitError r))
-> Request
-> IO (Either FetchFault (BodyOutcome r))
forall a.
Manager
-> ProgressFloor
-> (IO ByteString -> IO (Either LimitError a))
-> Request
-> IO (Either FetchFault (BodyOutcome a))
withSuccessBody (OriginClient -> Manager
ocManager OriginClient
origin) (Limits -> ProgressFloor
progressFloor (OriginClient -> Limits
ocLimits OriginClient
origin)) IO ByteString -> IO (Either LimitError r)
consume) (Text
-> Maybe ClientCredential
-> MetadataForm
-> PackageName
-> Either UrlFormationError Request
metadataRequest (OriginClient -> Text
originBaseUrl OriginClient
origin) (OriginClient -> Maybe ClientCredential
ocToken OriginClient
origin) MetadataForm
Full PackageName
name))

decodeNpm :: TracingPort -> OriginClient -> PackageName -> PackumentRead -> IO ByteString -> IO (Either LimitError (StreamResult (Walked TreeRead)))
decodeNpm :: TracingPort
-> OriginClient
-> PackageName
-> PackumentRead
-> IO ByteString
-> IO (Either LimitError (StreamResult (Walked TreeRead)))
decodeNpm TracingPort
tracing OriginClient
origin PackageName
name PackumentRead
mode = TracingPort -> forall a. PackageName -> IO a -> IO a
spanMetadataDecode TracingPort
tracing PackageName
name (IO (Either LimitError (StreamResult (Walked TreeRead)))
 -> IO (Either LimitError (StreamResult (Walked TreeRead))))
-> (IO ByteString
    -> IO (Either LimitError (StreamResult (Walked TreeRead))))
-> IO ByteString
-> IO (Either LimitError (StreamResult (Walked TreeRead)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Limits
-> PackageName
-> PackumentRead
-> IO ByteString
-> IO (Either LimitError (StreamResult (Walked TreeRead)))
readNpmPackument (OriginClient -> Limits
ocLimits OriginClient
origin) PackageName
name PackumentRead
mode

-- | Walk a packument's chunks into aeson's tree with the production field policy, over a table keyed afresh for the read.
readNpmPackument :: Limits -> PackageName -> PackumentRead -> IO ByteString -> IO (Either LimitError (StreamResult (Walked TreeRead)))
readNpmPackument :: Limits
-> PackageName
-> PackumentRead
-> IO ByteString
-> IO (Either LimitError (StreamResult (Walked TreeRead)))
readNpmPackument Limits
limits PackageName
name PackumentRead
mode IO ByteString
readChunk = do
    table <- SipKey -> [Text] -> InternTable
newInternTable (SipKey -> [Text] -> InternTable)
-> IO SipKey -> IO ([Text] -> InternTable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SipKey
newTableKey IO ([Text] -> InternTable) -> IO [Text] -> IO InternTable
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Text] -> IO [Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
releaseUniqueFields
    readJsonWalk (MetadataBodyLimit (maxMetadataBytes limits)) (npmPackumentWalk limits name mode table) readChunk

-- | The production packument walk into aeson's tree over a caller's intern table.
npmPackumentWalk :: Limits -> PackageName -> PackumentRead -> InternTable -> TokenResult -> Step (Walked TreeRead)
npmPackumentWalk :: Limits
-> PackageName
-> PackumentRead
-> InternTable
-> TokenResult
-> Step (Walked TreeRead)
npmPackumentWalk Limits
limits PackageName
name PackumentRead
mode InternTable
table = Trees
-> Int
-> PackumentRead
-> FieldStep
     TreeRead (NpmFieldOf (Built Trees)) (Step (Walked TreeRead))
-> (TreeRead -> Text -> Bool)
-> InternTable
-> TreeRead
-> TokenResult
-> Step (Walked TreeRead)
forall b r s.
(Build b r, Result r ~ Walked s) =>
b
-> Int
-> PackumentRead
-> FieldStep s (NpmFieldOf (Built b)) r
-> (s -> Text -> Bool)
-> InternTable
-> s
-> TokenResult
-> r
npmWalk Trees
Trees (Limits -> Int
maxNestingDepth Limits
limits) PackumentRead
mode ((TreeRead -> NpmFieldOf Value -> Either LimitError TreeRead)
-> FieldStep TreeRead (NpmFieldOf Value) (Step (Walked TreeRead))
forall s field r.
(s -> field -> Either LimitError s) -> FieldStep s field r
pureStep (Limits
-> PackageName
-> TreeRead
-> NpmFieldOf Value
-> Either LimitError TreeRead
treeStep Limits
limits PackageName
name)) TreeRead -> Text -> Bool
keepsTreeRelease InternTable
table TreeRead
emptyTreeRead

-- | What a full read finishes with: the read's table, and its typed facts and packed releases.
type NpmFullRead = Walked PackedRead

-- | Walk a whole packument's chunks into its packed form, over a table keyed afresh for the read.
readNpmFull :: Limits -> PackageName -> Text -> IO ByteString -> IO (Either LimitError (StreamResult NpmFullRead))
readNpmFull :: Limits
-> PackageName
-> Text
-> IO ByteString
-> IO (Either LimitError (StreamResult NpmFullRead))
readNpmFull Limits
limits PackageName
name Text
base IO ByteString
readChunk = do
    (table, writer) <- IO SipKey
newTableKey IO SipKey
-> (SipKey -> IO (InternTable, Writer RealWorld))
-> IO (InternTable, Writer RealWorld)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SipKey
key -> ST RealWorld (InternTable, Writer RealWorld)
-> IO (InternTable, Writer RealWorld)
forall a. ST RealWorld a -> IO a
stToIO (Text
-> PackageName
-> InternTable
-> ST RealWorld (InternTable, Writer RealWorld)
forall st.
Text
-> PackageName -> InternTable -> ST st (InternTable, Writer st)
npmFullTable Text
base PackageName
name (SipKey -> [Text] -> InternTable
newInternTable SipKey
key [Text]
releaseUniqueFields))
    readJsonWalkST stToIO (MetadataBodyLimit (maxMetadataBytes limits)) (npmFullWalk writer limits name table) readChunk

{- | A full read's table with the source author pointer every served release holds, and the writer
that packs each release against it.
-}
npmFullTable :: Text -> PackageName -> InternTable -> ST st (InternTable, Writer st)
npmFullTable :: forall st.
Text
-> PackageName -> InternTable -> ST st (InternTable, Writer st)
npmFullTable Text
base PackageName
name InternTable
table0 = (InternTable
seeded,) (Writer st -> (InternTable, Writer st))
-> ST st (Writer st) -> ST st (InternTable, Writer st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Entry, Entry) -> ST st (Writer st)
forall st. Maybe (Entry, Entry) -> ST st (Writer st)
newWriter ((Entry, Entry) -> Maybe (Entry, Entry)
forall a. a -> Maybe a
Just (Entry
authorKey, Entry
pointer))
  where
    Interned Entry
authorKey InternTable
withKey = Name -> InternTable -> Interned
internName (Text -> Name
decodedName Text
"author") InternTable
table0
    Interned Entry
pointer InternTable
seeded = Name -> InternTable -> Interned
internName (Text -> Name
decodedName (Text -> PackageName -> Text
authorPointer Text
base PackageName
name)) InternTable
withKey

-- | The production full-read walk: each kept release packed by the writer against the caller's table.
npmFullWalk :: Writer st -> Limits -> PackageName -> InternTable -> TokenResult -> ST st (Steps (ST st) NpmFullRead)
npmFullWalk :: forall st.
Writer st
-> Limits
-> PackageName
-> InternTable
-> TokenResult
-> ST st (Steps (ST st) NpmFullRead)
npmFullWalk Writer st
writer Limits
limits PackageName
name InternTable
table = Writer st
-> Int
-> PackumentRead
-> FieldStep
     PackedRead
     (NpmFieldOf (Built (Writer st)))
     (ST st (Steps (ST st) NpmFullRead))
-> (PackedRead -> Text -> Bool)
-> InternTable
-> PackedRead
-> TokenResult
-> ST st (Steps (ST st) NpmFullRead)
forall b r s.
(Build b r, Result r ~ Walked s) =>
b
-> Int
-> PackumentRead
-> FieldStep s (NpmFieldOf (Built b)) r
-> (s -> Text -> Bool)
-> InternTable
-> s
-> TokenResult
-> r
npmWalk Writer st
writer (Limits -> Int
maxNestingDepth Limits
limits) PackumentRead
WholePackument (Writer st
-> Limits
-> PackageName
-> PackedRead
-> NpmFieldOf ()
-> (Either LimitError PackedRead
    -> ST st (Steps (ST st) NpmFullRead))
-> ST st (Steps (ST st) NpmFullRead)
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 -> Text -> Bool
keepsPackedRelease InternTable
table PackedRead
emptyPackedRead
{-# INLINE npmFullWalk #-}

-- | Finish a full read over its sealed table, keeping its typed error classification.
projectNpmPacked :: Limits -> PackageName -> Text -> StreamResult NpmFullRead -> Either MetadataError (PackageInfo, PackedPackument)
projectNpmPacked :: Limits
-> PackageName
-> Text
-> StreamResult NpmFullRead
-> Either MetadataError (PackageInfo, PackedPackument)
projectNpmPacked Limits
limits PackageName
name Text
base StreamResult NpmFullRead
streamed = do
    Walked table acc <- (ParseError -> MetadataError)
-> Either ParseError NpmFullRead
-> Either MetadataError NpmFullRead
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 (Limits -> ParseError -> MetadataError
streamError Limits
limits) (StreamResult NpmFullRead -> Either ParseError NpmFullRead
forall a. StreamResult a -> Either ParseError a
streamValue StreamResult NpmFullRead
streamed)
    finishPacked limits name (authorPointer base name) (docTable (tableTexts table)) acc

fetchNpmVersion :: TracingPort -> OriginClient -> PackageName -> Version -> IO (Either MetadataError VersionRead)
fetchNpmVersion :: TracingPort
-> OriginClient
-> PackageName
-> Version
-> IO (Either MetadataError VersionRead)
fetchNpmVersion TracingPort
tracing OriginClient
origin PackageName
name Version
version = do
    result <- TracingPort
-> OriginClient
-> PackageName
-> (IO ByteString
    -> IO (Either LimitError (StreamResult (Walked TreeRead))))
-> IO (Either MetadataError (StreamResult (Walked TreeRead)))
forall r.
TracingPort
-> OriginClient
-> PackageName
-> (IO ByteString -> IO (Either LimitError r))
-> IO (Either MetadataError r)
fetchNpmBody TracingPort
tracing OriginClient
origin PackageName
name (TracingPort
-> OriginClient
-> PackageName
-> PackumentRead
-> IO ByteString
-> IO (Either LimitError (StreamResult (Walked TreeRead)))
decodeNpm TracingPort
tracing OriginClient
origin PackageName
name (Text -> PackumentRead
OneRelease (Version -> Text
renderVersion Version
version)))
    pure $ do
        streamed <- result
        projected <- projectNpmStream (ocLimits origin) name (originBaseUrl origin) streamed
        let selected = Version -> Int -> (PackageInfo, Value) -> VersionRead
selectNpmRead Version
version (StreamResult (Walked TreeRead) -> Int
forall a. StreamResult a -> Int
streamBytes StreamResult (Walked TreeRead)
streamed) (PackageInfo, Value)
projected
        pure selected{vrVersion = vrVersion selected >>= locationCheckedDoc (originBaseUrl origin)}

-- | Finish a streamed source, keeping its typed error classification.
projectNpmStream :: Limits -> PackageName -> Text -> StreamResult (Walked TreeRead) -> Either MetadataError (PackageInfo, Value)
projectNpmStream :: Limits
-> PackageName
-> Text
-> StreamResult (Walked TreeRead)
-> Either MetadataError (PackageInfo, Value)
projectNpmStream Limits
limits PackageName
name Text
base StreamResult (Walked TreeRead)
streamed = do
    Walked _ acc <- (ParseError -> MetadataError)
-> Either ParseError (Walked TreeRead)
-> Either MetadataError (Walked TreeRead)
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 (Limits -> ParseError -> MetadataError
streamError Limits
limits) (StreamResult (Walked TreeRead)
-> Either ParseError (Walked TreeRead)
forall a. StreamResult a -> Either ParseError a
streamValue StreamResult (Walked TreeRead)
streamed)
    finishTree limits name (authorPointer base name) acc

-- | Pair one release with its compact source object and the same document's latest tag.
selectNpmRead :: Version -> Int -> (PackageInfo, Value) -> VersionRead
selectNpmRead :: Version -> Int -> (PackageInfo, Value) -> VersionRead
selectNpmRead Version
version Int
bodyBytes (PackageInfo
info, Value
raw) =
    VersionRead
        { vrVersion :: Maybe VersionDoc
vrVersion = do
            details <- Text -> Map Text PackageDetails -> Maybe PackageDetails
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Version -> Text
renderVersion Version
version) (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info)
            selected <- selectNpmVersionDoc version (fst npmCached raw)
            pure VersionDoc{vdDetails = details, vdRaw = Just selected}
        , vrBodyBytes :: Int
vrBodyBytes = Int
bodyBytes
        , vrUpstreamLatest :: Maybe Version
vrUpstreamLatest = Text -> Map Text Version -> Maybe Version
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"latest" (PackageInfo -> Map Text Version
infoDistTags PackageInfo
info)
        }

authorPointer :: Text -> PackageName -> Text
authorPointer :: Text -> PackageName -> Text
authorPointer Text
base PackageName
name = Text
"See " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Either UrlFormationError Text -> Text
forall b a. b -> Either a b -> b
fromRight (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
name) (Text -> PackageName -> Either UrlFormationError Text
packageUrl Text
base PackageName
name)

locationCheckedDoc :: Text -> VersionDoc -> Maybe VersionDoc
locationCheckedDoc :: Text -> VersionDoc -> Maybe VersionDoc
locationCheckedDoc Text
upstreamBaseUrl VersionDoc
doc =
    (\PackageDetails
details -> VersionDoc
doc{vdDetails = details})
        (PackageDetails -> VersionDoc)
-> Maybe PackageDetails -> Maybe VersionDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AllowedHostPorts -> Text -> PackageDetails -> Maybe PackageDetails
enforceArtifactLocationsOf AllowedHostPorts
npmArtifactAuthorities Text
upstreamBaseUrl (VersionDoc -> PackageDetails
vdDetails VersionDoc
doc)

npmArtifactAuthorities :: AllowedHostPorts
npmArtifactAuthorities :: AllowedHostPorts
npmArtifactAuthorities = [Text] -> AllowedHostPorts
ecosystemArtifactAuthorities [Text]
npmArtifactHosts

-- | Select the object paired with a warm full projection under the same rendered version key.
selectNpmVersionDoc :: Version -> CachedDoc -> Maybe CachedDoc
selectNpmVersionDoc :: Version -> CachedDoc -> Maybe CachedDoc
selectNpmVersionDoc Version
version CachedDoc
doc = do
    Object packument <- (Value -> CachedDoc, CachedDoc -> Maybe Value)
-> CachedDoc -> Maybe Value
forall a b. (a, b) -> b
snd (Value -> CachedDoc, CachedDoc -> Maybe Value)
npmCached CachedDoc
doc
    versions <- objectField "versions" packument
    fst npmCached <$> KeyMap.lookup (Key.fromText (renderVersion version)) versions