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

{- | Wiring a per-request "Ecluse.Core.Registry.Metadata.MetadataClient" for the serve
path: the cross-cutting caching, metrics, and failure-logging policy wrapped around a
registry's raw fetch primitive.

The read boundary's /type/ lives in the registry layer (agnostic); a registry's raw
fetch primitive lives with that registry (npm's in
"Ecluse.Core.Registry.Npm.Metadata"). What lives __here__ is the serve-path policy
that is the same regardless of ecosystem: whether an origin is resolved through the
shared metadata cache, recording the upstream-fetch metrics, and logging a failure
once in the request's context. Keeping that policy in the serve layer is what lets the
registry layer stay free of the cache and telemetry.

The two operations differ in how they resolve. The full-manifest op resolves the whole
packument through the shared full-packument cache. The single-version op takes a
__hybrid__ path so a cold tarball gate need not pay a whole-packument decode to consult
one version (see 'newMetadataClient'): it consults a small @(package, version)@ cache, then
the warm full-packument cache __read-only__ (so a packument @GET@ followed by its tarball
gate still collapses to one upstream call), and only on a cold miss leads its own
__selective__ fetch -- parsing just the requested version out of the full bytes -- into the
@(package, version)@ cache, never writing the whole packument back to the shared cache.
-}
module Ecluse.Core.Server.Metadata (
    -- * Caching policy
    ManifestCaching (..),

    -- * Constructing a per-request read handle
    newMetadataClient,
) where

import Data.Map.Strict qualified as Map

import Ecluse.Core.Package (InvalidEntry, PackageDetails, PackageInfo (infoInvalidEntries, infoVersions), PackageName)
import Ecluse.Core.Registry.Metadata (
    Manifest (Manifest, manifestDigest, manifestInfo, manifestRaw),
    MetadataClient (..),
    MetadataError (MetadataBoundExceeded, MetadataNameMismatch, MetadataUndecodable, MetadataUnreachable, MetadataUrlUnformable),
 )

import Ecluse.Core.Server.Cache (
    CacheEntry (CacheEntry, entryDigest, entryInfo, entryRaw),
    MetadataCache,
    Source,
    cachedMetadata,
    cachedVersion,
    resolveMetadata,
    resolveVersion,
 )
import Ecluse.Core.Telemetry.Metrics qualified as Metric
import Ecluse.Core.Telemetry.Record (MetricsPort (..), timedSeconds)
import Ecluse.Core.Version (Version, renderVersion)

{- | How a read handle resolves the full manifest for one origin.

The two origins of a packument merge differ exactly here: the private origin is the
per-client authority and must not be shared, while the public origin is anonymous and
shared across every client.
-}
data ManifestCaching
    = {- | Resolve directly, uncached -- the per-client private origin, re-fetched every
      request so the upstream re-authorises each client's own forwarded credential.
      -}
      Uncached
    | {- | Resolve through the shared metadata cache under the origin's 'Source' key --
      the anonymous public origin, so concurrent and subsequent reads collapse to one
      upstream call. Both operations of the resulting handle share this one entry.
      -}
      Cached MetadataCache Source

{- | Build a per-request read handle from a registry's raw fetch primitives -- one that
fetches and projects the __full manifest__, one that fetches and __selectively__ projects a
__single version__ -- wiring them with the caching policy, the upstream-fetch metrics, and a
request-context failure log.

The full-manifest op resolves the whole packument through the shared full-packument cache.
The single-version op takes the __hybrid__ path that delivers the cheap cold tarball gate
while preserving the warm install one-call property:

  1. consult the small @(package, version)@ cache -- a hit (a positive snapshot, or a cached
     /determined absence/) returns at once;
  2. else consult the warm full-packument cache __read-only__ -- a hit selects the one version
     from the shared entry (so a packument @GET@ followed by its tarball gate is still one
     upstream call), and __does not__ populate the version cache;
  3. else (cold) lead the raw __single-version__ fetch -- which fetches the full bytes but
     parses only the requested version -- through the @(package, version)@ cache's
     single-flight, caching the resulting snapshot (or its determined absence) there, and
     __never__ writing the whole packument back to the shared cache.

For the 'Uncached' policy (the per-client private origin) there is no shared cache to
consult, so the single-version op is the raw selective fetch, uncached, re-run each request.

The failure log is invoked __once per real fetch__ (inside the cache's single-flight
leader), in the caller's logging context, so a coalesced follower never re-logs a
failure the leader already reported. The dropped-entry log ('logInvalid') is invoked the
same way (once per real full-manifest fetch, only when the projection dropped a
malformed entry), so an operator sees a degraded-but-served document without it
re-logging on every cache hit.
-}
newMetadataClient ::
    MetricsPort ->
    Metric.Upstream ->
    ManifestCaching ->
    (PackageName -> MetadataError -> IO ()) ->
    (PackageName -> [InvalidEntry] -> IO ()) ->
    (PackageName -> IO ()) ->
    (PackageName -> IO (Either MetadataError Manifest)) ->
    (PackageName -> Version -> IO (Either MetadataError (Maybe PackageDetails))) ->
    MetadataClient
newMetadataClient :: MetricsPort
-> Upstream
-> ManifestCaching
-> (PackageName -> MetadataError -> IO ())
-> (PackageName -> [InvalidEntry] -> IO ())
-> (PackageName -> IO ())
-> (PackageName -> IO (Either MetadataError Manifest))
-> (PackageName
    -> Version -> IO (Either MetadataError (Maybe PackageDetails)))
-> MetadataClient
newMetadataClient MetricsPort
metrics Upstream
upstream ManifestCaching
caching PackageName -> MetadataError -> IO ()
logFailure PackageName -> [InvalidEntry] -> IO ()
logInvalid PackageName -> IO ()
logFetch PackageName -> IO (Either MetadataError Manifest)
rawFetch PackageName
-> Version -> IO (Either MetadataError (Maybe PackageDetails))
rawFetchVersion =
    MetadataClient
        { fetchFullManifest :: PackageName -> IO (Either MetadataError Manifest)
fetchFullManifest = (Either MetadataError CacheEntry -> Either MetadataError Manifest)
-> IO (Either MetadataError CacheEntry)
-> IO (Either MetadataError Manifest)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CacheEntry -> Manifest)
-> Either MetadataError CacheEntry -> Either MetadataError Manifest
forall a b.
(a -> b) -> Either MetadataError a -> Either MetadataError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CacheEntry -> Manifest
entryToManifest) (IO (Either MetadataError CacheEntry)
 -> IO (Either MetadataError Manifest))
-> (PackageName -> IO (Either MetadataError CacheEntry))
-> PackageName
-> IO (Either MetadataError Manifest)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> IO (Either MetadataError CacheEntry)
resolveEntry
        , fetchVersionMetadata :: PackageName
-> Version -> IO (Either MetadataError (Maybe PackageDetails))
fetchVersionMetadata = PackageName
-> Version -> IO (Either MetadataError (Maybe PackageDetails))
resolveVersionHybrid
        }
  where
    resolveEntry :: PackageName -> IO (Either MetadataError CacheEntry)
    resolveEntry :: PackageName -> IO (Either MetadataError CacheEntry)
resolveEntry PackageName
name = case ManifestCaching
caching of
        ManifestCaching
Uncached -> PackageName -> IO (Either MetadataError CacheEntry)
manifestLeader PackageName
name
        Cached MetadataCache
cache Source
source -> MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> IO (Either MetadataError CacheEntry)
-> IO (Either MetadataError CacheEntry)
resolveMetadata MetricsPort
metrics MetadataCache
cache Source
source PackageName
name (PackageName -> IO (Either MetadataError CacheEntry)
manifestLeader PackageName
name)

    -- The full-manifest single-flight leader action: the real fetch, run only on a cache
    -- miss, metered, with any dropped malformed entries logged on success and a fetch
    -- failure logged once before its 'Left' is handed to the cache (which stores nothing
    -- and delivers the same value to every coalesced follower).
    manifestLeader :: PackageName -> IO (Either MetadataError CacheEntry)
    manifestLeader :: PackageName -> IO (Either MetadataError CacheEntry)
manifestLeader PackageName
name = do
        PackageName -> IO ()
logFetch PackageName
name
        MetricsPort
-> Upstream
-> IO (Either MetadataError CacheEntry)
-> IO (Either MetadataError CacheEntry)
forall a.
MetricsPort
-> Upstream
-> IO (Either MetadataError a)
-> IO (Either MetadataError a)
recordedFetch MetricsPort
metrics Upstream
upstream (IO (Either MetadataError CacheEntry)
 -> IO (Either MetadataError CacheEntry))
-> IO (Either MetadataError CacheEntry)
-> IO (Either MetadataError CacheEntry)
forall a b. (a -> b) -> a -> b
$
            PackageName -> IO (Either MetadataError Manifest)
rawFetch PackageName
name IO (Either MetadataError Manifest)
-> (Either MetadataError Manifest
    -> IO (Either MetadataError CacheEntry))
-> IO (Either MetadataError CacheEntry)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Right Manifest
manifest -> do
                    let invalid :: [InvalidEntry]
invalid = PackageInfo -> [InvalidEntry]
infoInvalidEntries (Manifest -> PackageInfo
manifestInfo Manifest
manifest)
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([InvalidEntry] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InvalidEntry]
invalid) (PackageName -> [InvalidEntry] -> IO ()
logInvalid PackageName
name [InvalidEntry]
invalid)
                    Either MetadataError CacheEntry
-> IO (Either MetadataError CacheEntry)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CacheEntry -> Either MetadataError CacheEntry
forall a b. b -> Either a b
Right (PackageInfo -> CachedDoc -> ContentDigest -> CacheEntry
CacheEntry (Manifest -> PackageInfo
manifestInfo Manifest
manifest) (Manifest -> CachedDoc
manifestRaw Manifest
manifest) (Manifest -> ContentDigest
manifestDigest Manifest
manifest)))
                Left MetadataError
err -> PackageName -> MetadataError -> IO ()
logFailure PackageName
name MetadataError
err IO ()
-> IO (Either MetadataError CacheEntry)
-> IO (Either MetadataError CacheEntry)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either MetadataError CacheEntry
-> IO (Either MetadataError CacheEntry)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetadataError -> Either MetadataError CacheEntry
forall a b. a -> Either a b
Left MetadataError
err)

    -- The single-version hybrid: the small version cache, then the warm full cache
    -- read-only, then a cold selective fetch -- or, uncached, the raw selective fetch.
    resolveVersionHybrid :: PackageName -> Version -> IO (Either MetadataError (Maybe PackageDetails))
    resolveVersionHybrid :: PackageName
-> Version -> IO (Either MetadataError (Maybe PackageDetails))
resolveVersionHybrid PackageName
name Version
version = case ManifestCaching
caching of
        ManifestCaching
Uncached -> PackageName
-> Version -> IO (Either MetadataError (Maybe PackageDetails))
versionLeader PackageName
name Version
version
        Cached MetadataCache
cache Source
source -> do
            -- (1) The single-version cache: a positive snapshot or a cached determined
            -- absence both short-circuit.
            cached <- MetadataCache
-> Source
-> PackageName
-> Version
-> IO (Maybe (Maybe PackageDetails))
cachedVersion MetadataCache
cache Source
source PackageName
name Version
version
            case cached of
                Just Maybe PackageDetails
details -> Either MetadataError (Maybe PackageDetails)
-> IO (Either MetadataError (Maybe PackageDetails))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageDetails -> Either MetadataError (Maybe PackageDetails)
forall a b. b -> Either a b
Right Maybe PackageDetails
details)
                Maybe (Maybe PackageDetails)
Nothing -> do
                    -- (2) The warm full-packument cache, read-only: select the version from
                    -- the shared entry the packument @GET@ populated, never writing back to
                    -- the version cache (the install one-call property).
                    warm <- MetadataCache -> Source -> PackageName -> IO (Maybe CacheEntry)
cachedMetadata MetadataCache
cache Source
source PackageName
name
                    case warm of
                        Just CacheEntry
entry -> Either MetadataError (Maybe PackageDetails)
-> IO (Either MetadataError (Maybe PackageDetails))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageDetails -> Either MetadataError (Maybe PackageDetails)
forall a b. b -> Either a b
Right (Version -> PackageInfo -> Maybe PackageDetails
selectVersion Version
version (CacheEntry -> PackageInfo
entryInfo CacheEntry
entry)))
                        -- (3) Cold: lead the selective fetch through the version cache.
                        Maybe CacheEntry
Nothing -> MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> Version
-> IO (Either MetadataError (Maybe PackageDetails))
-> IO (Either MetadataError (Maybe PackageDetails))
resolveVersion MetricsPort
metrics MetadataCache
cache Source
source PackageName
name Version
version (PackageName
-> Version -> IO (Either MetadataError (Maybe PackageDetails))
versionLeader PackageName
name Version
version)

    -- The single-version single-flight leader action: the real selective fetch, run only on
    -- a cold miss, metered and (on failure) logged once before its 'Left' is handed to the
    -- cache, exactly as the full-manifest leader.
    versionLeader :: PackageName -> Version -> IO (Either MetadataError (Maybe PackageDetails))
    versionLeader :: PackageName
-> Version -> IO (Either MetadataError (Maybe PackageDetails))
versionLeader PackageName
name Version
version = do
        PackageName -> IO ()
logFetch PackageName
name
        MetricsPort
-> Upstream
-> IO (Either MetadataError (Maybe PackageDetails))
-> IO (Either MetadataError (Maybe PackageDetails))
forall a.
MetricsPort
-> Upstream
-> IO (Either MetadataError a)
-> IO (Either MetadataError a)
recordedFetch MetricsPort
metrics Upstream
upstream (IO (Either MetadataError (Maybe PackageDetails))
 -> IO (Either MetadataError (Maybe PackageDetails)))
-> IO (Either MetadataError (Maybe PackageDetails))
-> IO (Either MetadataError (Maybe PackageDetails))
forall a b. (a -> b) -> a -> b
$
            PackageName
-> Version -> IO (Either MetadataError (Maybe PackageDetails))
rawFetchVersion PackageName
name Version
version IO (Either MetadataError (Maybe PackageDetails))
-> (Either MetadataError (Maybe PackageDetails)
    -> IO (Either MetadataError (Maybe PackageDetails)))
-> IO (Either MetadataError (Maybe PackageDetails))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Right Maybe PackageDetails
details -> Either MetadataError (Maybe PackageDetails)
-> IO (Either MetadataError (Maybe PackageDetails))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageDetails -> Either MetadataError (Maybe PackageDetails)
forall a b. b -> Either a b
Right Maybe PackageDetails
details)
                Left MetadataError
err -> PackageName -> MetadataError -> IO ()
logFailure PackageName
name MetadataError
err IO ()
-> IO (Either MetadataError (Maybe PackageDetails))
-> IO (Either MetadataError (Maybe PackageDetails))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either MetadataError (Maybe PackageDetails)
-> IO (Either MetadataError (Maybe PackageDetails))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetadataError -> Either MetadataError (Maybe PackageDetails)
forall a b. a -> Either a b
Left MetadataError
err)

-- Select one version's details out of a parsed packument, by its rendered form.
selectVersion :: Version -> PackageInfo -> Maybe PackageDetails
selectVersion :: Version -> PackageInfo -> Maybe PackageDetails
selectVersion Version
version PackageInfo
info = 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)

-- Widen a cached entry back to the read handle's 'Manifest': the same three fields,
-- named for the boundary each type serves (the cache stores, the handle answers).
entryToManifest :: CacheEntry -> Manifest
entryToManifest :: CacheEntry -> Manifest
entryToManifest CacheEntry
entry =
    Manifest
        { manifestInfo :: PackageInfo
manifestInfo = CacheEntry -> PackageInfo
entryInfo CacheEntry
entry
        , manifestRaw :: CachedDoc
manifestRaw = CacheEntry -> CachedDoc
entryRaw CacheEntry
entry
        , manifestDigest :: ContentDigest
manifestDigest = CacheEntry -> ContentDigest
entryDigest CacheEntry
entry
        }

{- Record one upstream metadata fetch around the leader action: its latency on a
successful resolve, or the bounded error cause otherwise. Wrapping the leader -- which
runs only on a cache miss -- means the public path records real upstream calls, not
cache hits. Value-agnostic in the payload, so it wraps either leg's leader (a
full-manifest 'CacheEntry' or a single-version snapshot); the outcome passes through
untouched, so the caller's degrade is unchanged. -}
recordedFetch :: MetricsPort -> Metric.Upstream -> IO (Either MetadataError a) -> IO (Either MetadataError a)
recordedFetch :: forall a.
MetricsPort
-> Upstream
-> IO (Either MetadataError a)
-> IO (Either MetadataError a)
recordedFetch MetricsPort
metrics Upstream
upstream IO (Either MetadataError a)
action = do
    (result, seconds) <- IO (Either MetadataError a) -> IO (Either MetadataError a, Double)
forall (m :: * -> *) a. MonadIO m => m a -> m (a, Double)
timedSeconds IO (Either MetadataError a)
action
    case result of
        Right a
_ -> MetricsPort -> Upstream -> StatusClass -> Double -> IO ()
mpUpstreamFetch MetricsPort
metrics Upstream
upstream StatusClass
Metric.Status2xx Double
seconds
        Left MetadataError
err -> MetricsPort -> Upstream -> Cause -> IO ()
mpUpstreamFetchError MetricsPort
metrics Upstream
upstream (MetadataError -> Cause
metadataErrorCause MetadataError
err)
    pure result

{- Classify a leader-fetch failure into the bounded @ecluse.upstream.fetch.errors@
cause: a decode or name failure is a decode fault, an unreachable upstream a
connection fault, a bound breach or a config fault the catch-all other. Read off the
typed 'MetadataError' rather than any stringly error text, so the cause stays bounded
by construction. -}
metadataErrorCause :: MetadataError -> Metric.Cause
metadataErrorCause :: MetadataError -> Cause
metadataErrorCause = \case
    MetadataError
MetadataUndecodable -> Cause
Metric.Decode
    MetadataNameMismatch Text
_ -> Cause
Metric.Decode
    MetadataBoundExceeded LimitError
_ -> Cause
Metric.OtherCause
    MetadataUrlUnformable UrlFormationError
_ -> Cause
Metric.OtherCause
    MetadataUnreachable TransportFault
_ -> Cause
Metric.Connection