-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE RoleAnnotations #-}

{- | Caching, metrics, and failure logs around registry metadata reads.
The caching policy is not exported, and an origin carries its credential posture in its type.
'publicMetadataClient' takes reads over a 'Public' origin, which only
'Ecluse.Core.Registry.Origin.anonymousOrigin' builds and which presents no credential, so reads
that carry a caller's credential cannot reach the shared cache. 'privateMetadataClient' takes no
cache at all. Anonymous public reads use the selected provider's typed retention capabilities.
-}
module Ecluse.Core.Server.Metadata (
    -- * Constructing a per-request read handle
    MetadataReads,
    newMetadataReads,
    withinRequestCap,
    publicMetadataClient,
    preparePublicVersion,
    privateMetadataClient,

    -- * Projecting one version
    selectVersion,
) where

import Data.Map.Strict qualified as Map

import Ecluse.Core.Package (InvalidEntry, PackageDetails, PackageInfo (infoInvalidEntries, infoVersions), PackageName)
import Ecluse.Core.Registry (FetchFault (FetchBoundExceeded, FetchTransport, FetchUrlUnformable))
import Ecluse.Core.Registry.Exchange (withinServeCap)
import Ecluse.Core.Registry.Metadata (
    Manifest (Manifest, manifestBodyBytes, manifestDigest, manifestInfo, manifestRaw),
    MetadataClient (..),
    MetadataError (MetadataAbsent, MetadataAuthorisationFailure, MetadataBoundExceeded, MetadataFetch, MetadataHttpFailure, MetadataNameMismatch, MetadataUndecodable),
    VersionRead,
 )
import Ecluse.Core.Registry.Origin (OriginClient, OriginFor, Private, Public, originClientOf)
import Ecluse.Core.Security (ProgressFloor)

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

-- Private reads re-authorise the caller at the upstream, so only anonymous public metadata
-- resolves through the shared cache, keyed by the origin's Source.
data ManifestCaching
    = Uncached
    | Cached MetadataCache Source

{- | One origin's raw reads bound to their observers, before a caching policy settles them into a
'MetadataClient'. The phantom is the posture of the origin the reads were bound to.
-}
newtype MetadataReads (posture :: Type) = MetadataReads (Metric.Upstream -> ManifestCaching -> ClientWiring)

-- As on OriginFor in Ecluse.Core.Registry.Origin: the default phantom role would let coerce
-- turn per-caller reads into the ones the public builder accepts.
type role MetadataReads nominal

-- | Bind one origin's raw reads to the metrics port and the failure, invalid-entry, and fetch logs.
newMetadataReads ::
    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 :: 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 OriginClient -> PackageName -> IO (Either MetadataError Manifest)
rawFetch OriginClient
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
rawFetchVersion OriginFor posture
origin =
    (Upstream -> ManifestCaching -> ClientWiring)
-> MetadataReads posture
forall posture.
(Upstream -> ManifestCaching -> ClientWiring)
-> MetadataReads posture
MetadataReads ((Upstream -> ManifestCaching -> ClientWiring)
 -> MetadataReads posture)
-> (Upstream -> ManifestCaching -> ClientWiring)
-> MetadataReads posture
forall a b. (a -> b) -> a -> b
$ \Upstream
upstream ManifestCaching
caching ->
        ClientWiring
            { cwMetrics :: MetricsPort
cwMetrics = MetricsPort
metrics
            , cwUpstream :: Upstream
cwUpstream = Upstream
upstream
            , cwCaching :: ManifestCaching
cwCaching = ManifestCaching
caching
            , cwFetch :: PackageName -> IO (Either MetadataError Manifest)
cwFetch = OriginClient -> PackageName -> IO (Either MetadataError Manifest)
rawFetch OriginClient
client
            , cwFetchVersion :: PackageName -> Version -> IO (Either MetadataError VersionRead)
cwFetchVersion = OriginClient
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
rawFetchVersion OriginClient
client
            , cwLogFailure :: PackageName -> MetadataError -> IO ()
cwLogFailure = PackageName -> MetadataError -> IO ()
logFailure
            , cwLogInvalid :: PackageName -> [InvalidEntry] -> IO ()
cwLogInvalid = PackageName -> [InvalidEntry] -> IO ()
logInvalid
            , cwLogFetch :: PackageName -> IO ()
cwLogFetch = PackageName -> IO ()
logFetch
            }
  where
    client :: OriginClient
client = OriginFor posture -> OriginClient
forall posture. OriginFor posture -> OriginClient
originClientOf OriginFor posture
origin

{- | Hold each raw read to the floor's serve-path cap, so a single-flight leader fails before the
request timeout ends its request.
-}
withinRequestCap :: ProgressFloor -> MetadataReads posture -> MetadataReads posture
withinRequestCap :: forall posture.
ProgressFloor -> MetadataReads posture -> MetadataReads posture
withinRequestCap ProgressFloor
progress (MetadataReads Upstream -> ManifestCaching -> ClientWiring
settle) = (Upstream -> ManifestCaching -> ClientWiring)
-> MetadataReads posture
forall posture.
(Upstream -> ManifestCaching -> ClientWiring)
-> MetadataReads posture
MetadataReads ((Upstream -> ManifestCaching -> ClientWiring)
 -> MetadataReads posture)
-> (Upstream -> ManifestCaching -> ClientWiring)
-> MetadataReads posture
forall a b. (a -> b) -> a -> b
$ \Upstream
upstream ManifestCaching
caching ->
    let wiring :: ClientWiring
wiring = Upstream -> ManifestCaching -> ClientWiring
settle Upstream
upstream ManifestCaching
caching
     in ClientWiring
wiring
            { cwFetch = withinServeCap progress MetadataFetch . cwFetch wiring
            , cwFetchVersion = \PackageName
name -> ProgressFloor
-> (FetchFault -> MetadataError)
-> IO (Either MetadataError VersionRead)
-> IO (Either MetadataError VersionRead)
forall e a.
ProgressFloor
-> (FetchFault -> e) -> IO (Either e a) -> IO (Either e a)
withinServeCap ProgressFloor
progress FetchFault -> MetadataError
MetadataFetch (IO (Either MetadataError VersionRead)
 -> IO (Either MetadataError VersionRead))
-> (Version -> IO (Either MetadataError VersionRead))
-> Version
-> IO (Either MetadataError VersionRead)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientWiring
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
cwFetchVersion ClientWiring
wiring PackageName
name
            }

-- | The anonymous origin's handle, resolving through the shared cache under its 'Source' key.
publicMetadataClient :: MetadataCache -> Source -> MetadataReads Public -> MetadataClient
publicMetadataClient :: MetadataCache -> Source -> MetadataReads Public -> MetadataClient
publicMetadataClient MetadataCache
cache Source
source (MetadataReads Upstream -> ManifestCaching -> ClientWiring
settle) = ClientWiring -> MetadataClient
newMetadataClient (Upstream -> ManifestCaching -> ClientWiring
settle Upstream
Metric.Public (MetadataCache -> Source -> ManifestCaching
Cached MetadataCache
cache Source
source))

-- | Prepare anonymous selected metadata while keeping its logs and upstream metrics on the leader.
preparePublicVersion :: MetadataCache -> Source -> MetadataReads Public -> PackageName -> Version -> IO (PreparedStore MetadataError VersionRead)
preparePublicVersion :: MetadataCache
-> Source
-> MetadataReads Public
-> PackageName
-> Version
-> IO (PreparedStore MetadataError VersionRead)
preparePublicVersion MetadataCache
cache Source
source (MetadataReads Upstream -> ManifestCaching -> ClientWiring
settle) PackageName
name Version
version =
    MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> Version
-> IO (Either MetadataError VersionRead)
-> IO (PreparedStore MetadataError VersionRead)
prepareVersion (ClientWiring -> MetricsPort
cwMetrics ClientWiring
wiring) MetadataCache
cache Source
source PackageName
name Version
version (ClientWiring
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
versionLeader ClientWiring
wiring PackageName
name Version
version)
  where
    wiring :: ClientWiring
wiring = Upstream -> ManifestCaching -> ClientWiring
settle Upstream
Metric.Public (MetadataCache -> Source -> ManifestCaching
Cached MetadataCache
cache Source
source)

-- | The per-caller origin's handle. It takes no cache, so the upstream re-authorises every caller.
privateMetadataClient :: MetadataReads Private -> MetadataClient
privateMetadataClient :: MetadataReads Private -> MetadataClient
privateMetadataClient (MetadataReads Upstream -> ManifestCaching -> ClientWiring
settle) = ClientWiring -> MetadataClient
newMetadataClient (Upstream -> ManifestCaching -> ClientWiring
settle Upstream
Metric.Private ManifestCaching
Uncached)

-- One origin's raw reads and observers, already settled by a caching policy and an upstream
-- label. Bundled so each read below takes it whole rather than nine positional parameters.
data ClientWiring = ClientWiring
    { ClientWiring -> MetricsPort
cwMetrics :: MetricsPort
    , ClientWiring -> Upstream
cwUpstream :: Metric.Upstream
    , ClientWiring -> ManifestCaching
cwCaching :: ManifestCaching
    , ClientWiring -> PackageName -> IO (Either MetadataError Manifest)
cwFetch :: PackageName -> IO (Either MetadataError Manifest)
    , ClientWiring
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
cwFetchVersion :: PackageName -> Version -> IO (Either MetadataError VersionRead)
    , ClientWiring -> PackageName -> MetadataError -> IO ()
cwLogFailure :: PackageName -> MetadataError -> IO ()
    , ClientWiring -> PackageName -> [InvalidEntry] -> IO ()
cwLogInvalid :: PackageName -> [InvalidEntry] -> IO ()
    , ClientWiring -> PackageName -> IO ()
cwLogFetch :: PackageName -> IO ()
    }

newMetadataClient :: ClientWiring -> MetadataClient
newMetadataClient :: ClientWiring -> MetadataClient
newMetadataClient ClientWiring
wiring =
    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
. ClientWiring -> PackageName -> IO (Either MetadataError CacheEntry)
resolveEntry ClientWiring
wiring
        , fetchVersionMetadata :: PackageName -> Version -> IO (Either MetadataError VersionRead)
fetchVersionMetadata = ClientWiring
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
resolveSelectedVersion ClientWiring
wiring
        }

resolveEntry :: ClientWiring -> PackageName -> IO (Either MetadataError CacheEntry)
resolveEntry :: ClientWiring -> PackageName -> IO (Either MetadataError CacheEntry)
resolveEntry ClientWiring
wiring PackageName
name = case ClientWiring -> ManifestCaching
cwCaching ClientWiring
wiring of
    ManifestCaching
Uncached -> ClientWiring -> PackageName -> IO (Either MetadataError CacheEntry)
manifestLeader ClientWiring
wiring PackageName
name
    Cached MetadataCache
cache Source
source -> MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> IO (Either MetadataError CacheEntry)
-> IO (Either MetadataError CacheEntry)
resolveMetadata (ClientWiring -> MetricsPort
cwMetrics ClientWiring
wiring) MetadataCache
cache Source
source PackageName
name (ClientWiring -> PackageName -> IO (Either MetadataError CacheEntry)
manifestLeader ClientWiring
wiring PackageName
name)

manifestLeader :: ClientWiring -> PackageName -> IO (Either MetadataError CacheEntry)
manifestLeader :: ClientWiring -> PackageName -> IO (Either MetadataError CacheEntry)
manifestLeader ClientWiring
wiring PackageName
name = do
    ClientWiring -> PackageName -> IO ()
cwLogFetch ClientWiring
wiring 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 (ClientWiring -> MetricsPort
cwMetrics ClientWiring
wiring) (ClientWiring -> Upstream
cwUpstream ClientWiring
wiring) (IO (Either MetadataError CacheEntry)
 -> IO (Either MetadataError CacheEntry))
-> IO (Either MetadataError CacheEntry)
-> IO (Either MetadataError CacheEntry)
forall a b. (a -> b) -> a -> b
$
        (Manifest -> IO CacheEntry)
-> Either MetadataError Manifest
-> IO (Either MetadataError CacheEntry)
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) -> Either MetadataError a -> f (Either MetadataError b)
traverse (ClientWiring -> PackageName -> Manifest -> IO CacheEntry
entryOfManifest ClientWiring
wiring PackageName
name) (Either MetadataError Manifest
 -> IO (Either MetadataError CacheEntry))
-> IO (Either MetadataError Manifest)
-> IO (Either MetadataError CacheEntry)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ClientWiring
-> PackageName
-> IO (Either MetadataError Manifest)
-> IO (Either MetadataError Manifest)
forall a.
ClientWiring
-> PackageName
-> IO (Either MetadataError a)
-> IO (Either MetadataError a)
loggingFailure ClientWiring
wiring PackageName
name (ClientWiring -> PackageName -> IO (Either MetadataError Manifest)
cwFetch ClientWiring
wiring PackageName
name)

entryOfManifest :: ClientWiring -> PackageName -> Manifest -> IO CacheEntry
entryOfManifest :: ClientWiring -> PackageName -> Manifest -> IO CacheEntry
entryOfManifest ClientWiring
wiring PackageName
name 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) (ClientWiring -> PackageName -> [InvalidEntry] -> IO ()
cwLogInvalid ClientWiring
wiring PackageName
name [InvalidEntry]
invalid)
    CacheEntry -> IO CacheEntry
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageInfo -> CachedDoc -> Int -> ContentDigest -> CacheEntry
CacheEntry (Manifest -> PackageInfo
manifestInfo Manifest
manifest) (Manifest -> CachedDoc
manifestRaw Manifest
manifest) (Manifest -> Int
manifestBodyBytes Manifest
manifest) (Manifest -> ContentDigest
manifestDigest Manifest
manifest))

resolveSelectedVersion :: ClientWiring -> PackageName -> Version -> IO (Either MetadataError VersionRead)
resolveSelectedVersion :: ClientWiring
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
resolveSelectedVersion ClientWiring
wiring PackageName
name Version
version = case ClientWiring -> ManifestCaching
cwCaching ClientWiring
wiring of
    ManifestCaching
Uncached -> ClientWiring
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
versionLeader ClientWiring
wiring PackageName
name Version
version
    Cached MetadataCache
cache Source
source -> MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> Version
-> IO (Either MetadataError VersionRead)
-> IO (Either MetadataError VersionRead)
resolveVersion (ClientWiring -> MetricsPort
cwMetrics ClientWiring
wiring) MetadataCache
cache Source
source PackageName
name Version
version (ClientWiring
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
versionLeader ClientWiring
wiring PackageName
name Version
version)

versionLeader :: ClientWiring -> PackageName -> Version -> IO (Either MetadataError VersionRead)
versionLeader :: ClientWiring
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
versionLeader ClientWiring
wiring PackageName
name Version
version = do
    ClientWiring -> PackageName -> IO ()
cwLogFetch ClientWiring
wiring PackageName
name
    MetricsPort
-> Upstream
-> IO (Either MetadataError VersionRead)
-> IO (Either MetadataError VersionRead)
forall a.
MetricsPort
-> Upstream
-> IO (Either MetadataError a)
-> IO (Either MetadataError a)
recordedFetch (ClientWiring -> MetricsPort
cwMetrics ClientWiring
wiring) (ClientWiring -> Upstream
cwUpstream ClientWiring
wiring) (IO (Either MetadataError VersionRead)
 -> IO (Either MetadataError VersionRead))
-> IO (Either MetadataError VersionRead)
-> IO (Either MetadataError VersionRead)
forall a b. (a -> b) -> a -> b
$
        ClientWiring
-> PackageName
-> IO (Either MetadataError VersionRead)
-> IO (Either MetadataError VersionRead)
forall a.
ClientWiring
-> PackageName
-> IO (Either MetadataError a)
-> IO (Either MetadataError a)
loggingFailure ClientWiring
wiring PackageName
name (ClientWiring
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
cwFetchVersion ClientWiring
wiring PackageName
name Version
version)

loggingFailure :: ClientWiring -> PackageName -> IO (Either MetadataError a) -> IO (Either MetadataError a)
loggingFailure :: forall a.
ClientWiring
-> PackageName
-> IO (Either MetadataError a)
-> IO (Either MetadataError a)
loggingFailure ClientWiring
wiring PackageName
name IO (Either MetadataError a)
action = do
    result <- IO (Either MetadataError a)
action
    whenLeft_ result (cwLogFailure wiring name)
    pure result

-- | Find a version by its ecosystem-rendered key in a package snapshot.
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)

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
        , manifestBodyBytes :: Int
manifestBodyBytes = CacheEntry -> Int
entryBodyBytes CacheEntry
entry
        , manifestDigest :: ContentDigest
manifestDigest = CacheEntry -> ContentDigest
entryDigest CacheEntry
entry
        }

-- Only leaders record upstream work, so followers and retention hits do not inflate it.
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

metadataErrorCause :: MetadataError -> Metric.Cause
metadataErrorCause :: MetadataError -> Cause
metadataErrorCause = \case
    MetadataError
MetadataAbsent -> Cause
Metric.UpstreamStatus
    MetadataHttpFailure Int
_ -> Cause
Metric.UpstreamStatus
    MetadataAuthorisationFailure Int
_ -> Cause
Metric.OtherCause
    MetadataError
MetadataUndecodable -> Cause
Metric.Decode
    MetadataNameMismatch Text
_ -> Cause
Metric.Decode
    MetadataBoundExceeded LimitError
_ -> Cause
Metric.OtherCause
    MetadataFetch (FetchUrlUnformable UrlFormationError
_) -> Cause
Metric.OtherCause
    MetadataFetch (FetchBoundExceeded LimitError
_) -> Cause
Metric.OtherCause
    MetadataFetch (FetchTransport TransportFault
_) -> Cause
Metric.Connection