{- | The short-TTL, size-bounded metadata cache shared by the serve paths.

Resolving a package re-fetches its upstream packument, parses it, and evaluates
the rules. To avoid repeating the fetch and parse, the result (a coherent pair of
the parsed __packument metadata__, 'PackageInfo', and the __raw document__ it was
decoded from, 'CacheEntry') is held here in a short-TTL, size-bounded, STM-backed
cache (the @cache@ library backs the TTL store). Both serve paths share it: a
packument request and the tarball-gating fetch that follows reuse one fetch and
parse, and concurrent resolutions of a popular package __collapse to one upstream
call__ (single-flight).

== Per-source key

A packument is fetched from two distinct upstreams, a private origin and a public
origin, whose documents differ for the same package, so one entry cannot represent
both. The key is @(source, package)@: the source is the upstream's base URL, which
distinguishes any cached origin without naming a credential, so distinct upstreams
never cross-contaminate and the key never blurs the trust split.

== Credential-free; sharing is the caller's policy

The key carries __no credential dimension__ and the value is a canonical document,
so the cache stores nothing derived from a caller's credential. Whether a given
origin is handed to it, and so shared across clients, is the serve path's decision.

Under the default @passthrough@ access strategy only the anonymous public origin is
cached. The trusted private upstream is the per-client authority: it re-authorises
each request with that client's own forwarded credential, so the serve path fetches
it per request and never hands it here. Were a private entry cached under
@passthrough@, the credential-free key would let one client's entry serve another
client's private document within the TTL, bypassing the upstream's authorisation.
The public origin is anonymous, so one shared entry serves every client without
crossing a trust boundary. Other strategies make a shared private entry safe by
authorising each serve before it is returned (see
@docs\/architecture\/access-model.md@ → "Caching"); that gate lives on the serve
path, never in this store.

== Coherent pair

An entry holds the parsed 'PackageInfo' __and__ the raw 'Value' it was decoded
from, so a hit returns a typed view and the exact bytes that produced it. The
packument serve path needs both: it decides over the typed view but serves the raw
document edited in place, and the two must describe the same fetch.

What is cached is the __metadata, not the verdict__. The rules are re-evaluated on
the cached metadata each request, so time-sensitive rules
('Ecluse.Core.Rules.Types.AllowIfOlderThan') and the separately-synced advisory
tier stay correct; only each upstream's fetch and parse is memoised. The TTL is
short, and brief staleness is benign: a brand-new publish need not appear instantly
(see @docs\/architecture\/web-layer.md@ → "Metadata cache").

Two properties the @cache@ library does not provide on its own are layered here:

* __Resident-byte budget with recency-aware eviction.__ @cache@ expires by TTL but
  bounds neither entry count nor memory. Each entry is wrapped with an estimate of
  its resident footprint (a heavy packument, parsed plus raw, costs many times its
  wire size) and a last-access stamp bumped on every hit. An insert first purges
  expired entries, then evicts the __least-recently-used__ entries until the incoming
  entry fits within both a resident-byte budget ('cacheMaxBytes') and an entry count
  ('cacheMaxEntries'). Recency keeps a re-accessed hot head resident under pressure
  while shedding the one-shot tail; the byte budget bounds memory more faithfully
  than a count alone. The incoming entry is always admitted (the per-entry ceiling is
  the upstream body cap, not this budget).

* __Single-flight.__ @cache@'s own @fetchWithCache@ is lookup-then-fetch in plain
  'IO', so two concurrent misses would both fetch. 'resolveMetadata' instead
  installs an in-flight marker atomically, so the first miss fetches while concurrent
  misses wait on its result. The leader inserts the result into the store __before__
  removing its in-flight marker, so a caller arriving the instant the fetch returns
  still finds either the store entry or the marker (never a gap) and never re-leads a
  redundant fetch.

== Two coherent stores: the full packument and one version

This handle owns __two__ stores of the same shape (the TTL + size-bound + single-flight
machinery, 'SingleFlight', is shared between them):

  * the __full-packument__ store ('resolveMetadata' \/ 'cachedMetadata'), keyed by
    @(source, package)@, holding the 'CacheEntry' described above; and

  * a __single-version__ store ('resolveVersion' \/ 'cachedVersion'), keyed by
    @(source, package, version)@, holding just one version's
    'Ecluse.Core.Package.PackageDetails' (or its determined absence, a cached
    'Nothing'): the cold tarball gate's selectively-parsed result.

They are __isolated on writes__: a single-version resolution caches under its own
key and __never writes back__ to the full-packument store, so a cold tarball gate
cannot materialise a whole packument into the shared full cache. The serve path's
single-version read consults the warm full-packument store __read-only__ first (a
packument @GET@ followed by its tarball gate still collapses to one upstream call),
and only falls back to leading its own selective fetch into the version store when
the full entry is cold. Both stores enforce the resident-byte budget, and each
reports its own residency gauge: the full-packument store under
@ecluse.metadata_cache.resident_bytes@ and the single-version store under
@ecluse.metadata_cache.version.resident_bytes@. The hit\/miss counter and the
entry-count occupancy gauge stay about the full-packument store.

A third store memoises the __assembled representation__ ('resolveAssembled'): the
encoded merged document, keyed by its derived validator
('Ecluse.Core.Server.Pipeline.Packument.packumentETag'). The key is a fingerprint of
every input the document is a function of (the origin bodies, private included by
content digest; the survivor sets; the mount base), which makes the store
__content-addressed__: an entry can never be served stale, because changed inputs
produce a different key and simply miss. The resident-byte budget is the real bound
here, not the TTL, which only trims dead entries early. Cross-client safety follows
from the same property: a lookup key includes the digest of the private document
__this request's own authorised fetch returned__, so a client can only hit an entry
whose bytes its own inputs would deterministically re-produce. The transform is
shared, never the authorisation and never another client's view (the private-origin
caching prohibition is about credential-blind keying, which a content key is not).
Residency gauge: @ecluse.metadata_cache.assembled.resident_bytes@.
-}
module Ecluse.Core.Server.Cache (
    -- * Configuration
    CacheConfig (..),
    defaultCacheConfig,

    -- * The cache handle
    MetadataCache,
    newMetadataCache,

    -- * Cache entries
    Source (..),
    CacheEntry (..),
    weighCacheEntry,

    -- * Resolution
    resolveMetadata,
    resolveMetadataWith,
    cachedMetadata,
    cacheSize,

    -- * Single-version resolution
    resolveVersion,
    resolveVersionWith,
    cachedVersion,

    -- * Assembled-representation resolution
    resolveAssembled,
) where

import Data.Aeson (Value, encode)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.Cache (Cache)
import Data.Cache qualified as Cache
import Data.Map.Strict qualified as Map
import Data.Text.Short qualified as TS
import Data.Time (NominalDiffTime)
import System.Clock (Clock (Monotonic), TimeSpec (TimeSpec), getTime)
import UnliftIO.Exception (SomeAsyncException, mask, throwIO)

import Ecluse.Core.InFlight (guardInFlight)
import Ecluse.Core.Package (
    PackageDetails,
    PackageInfo,
    PackageName,
    pkgCanonical,
    pkgEcosystem,
    pkgNamespace,
    renderScope,
 )
import Ecluse.Core.Registry.Metadata (ContentDigest)
import Ecluse.Core.Telemetry.Metrics qualified as Metric
import Ecluse.Core.Telemetry.Record (
    MetricsPort,
    mpAssembledCacheResidentBytes,
    mpCacheEntries,
    mpCacheRequest,
    mpCacheResidentBytes,
    mpVersionCacheResidentBytes,
 )
import Ecluse.Core.Version (Version, renderVersion)

{- | The metadata cache's tunables, sourced from configuration: how long a parsed
packument stays fresh, how many distinct @(source, package)@ entries the cache holds,
and the resident-byte budget it keeps the held entries under before it evicts.
-}
data CacheConfig = CacheConfig
    { CacheConfig -> NominalDiffTime
cacheTtl :: NominalDiffTime
    {- ^ How long a cached 'CacheEntry' is served before it is re-fetched. Short
    by design: brief staleness is benign, and conditional-GET revalidates.
    -}
    , CacheConfig -> Int
cacheMaxEntries :: Int
    {- ^ The maximum number of distinct @(source, package)@ entries held; an insert
    past this evicts.
    -}
    , CacheConfig -> Int
cacheMaxBytes :: Int
    {- ^ The resident-byte budget the held entries are kept under. Each entry is
    weighted by an estimate of its resident footprint, and an insert past this evicts
    the least-recently-used entries until the budget holds. A heavy packument (the
    parsed view plus its raw document) costs many times its wire size, so this bounds
    memory more faithfully than the entry count alone.
    -}
    }
    deriving stock (CacheConfig -> CacheConfig -> Bool
(CacheConfig -> CacheConfig -> Bool)
-> (CacheConfig -> CacheConfig -> Bool) -> Eq CacheConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CacheConfig -> CacheConfig -> Bool
== :: CacheConfig -> CacheConfig -> Bool
$c/= :: CacheConfig -> CacheConfig -> Bool
/= :: CacheConfig -> CacheConfig -> Bool
Eq, Int -> CacheConfig -> ShowS
[CacheConfig] -> ShowS
CacheConfig -> String
(Int -> CacheConfig -> ShowS)
-> (CacheConfig -> String)
-> ([CacheConfig] -> ShowS)
-> Show CacheConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CacheConfig -> ShowS
showsPrec :: Int -> CacheConfig -> ShowS
$cshow :: CacheConfig -> String
show :: CacheConfig -> String
$cshowList :: [CacheConfig] -> ShowS
showList :: [CacheConfig] -> ShowS
Show)

{- | The default cache tunables: a 60-second TTL, 1024 entries, and a 256 MiB resident
budget: short enough that a new publish appears promptly, and large enough to hold a
normal install's working set of packages while capping the resident memory a handful of
heavy packuments could otherwise dominate.
-}
defaultCacheConfig :: CacheConfig
defaultCacheConfig :: CacheConfig
defaultCacheConfig =
    CacheConfig
        { cacheTtl :: NominalDiffTime
cacheTtl = NominalDiffTime
60
        , cacheMaxEntries :: Int
cacheMaxEntries = Int
1024
        , cacheMaxBytes :: Int
cacheMaxBytes = Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
        }

{- | Which upstream a cached packument was fetched from: the dimension that
partitions the cache by source so distinct upstreams never share an entry.

The discriminator is the upstream's __base URL__: an upstream is addressed at a
distinct URL, and the URL names a location, never a credential, so keying on it
keeps the trust split intact (the cached origin is fetched with its own token, supplied
through its fetch action; the source carries none). Under the default @passthrough@
strategy only the anonymous public origin is cached, so in practice the cache holds one
source per package; the dimension keeps the key honest about /which/ upstream an entry
is, never blurring the split.
-}
newtype Source = Source Text
    deriving stock (Source -> Source -> Bool
(Source -> Source -> Bool)
-> (Source -> Source -> Bool) -> Eq Source
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Source -> Source -> Bool
== :: Source -> Source -> Bool
$c/= :: Source -> Source -> Bool
/= :: Source -> Source -> Bool
Eq, Eq Source
Eq Source =>
(Source -> Source -> Ordering)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Source)
-> (Source -> Source -> Source)
-> Ord Source
Source -> Source -> Bool
Source -> Source -> Ordering
Source -> Source -> Source
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Source -> Source -> Ordering
compare :: Source -> Source -> Ordering
$c< :: Source -> Source -> Bool
< :: Source -> Source -> Bool
$c<= :: Source -> Source -> Bool
<= :: Source -> Source -> Bool
$c> :: Source -> Source -> Bool
> :: Source -> Source -> Bool
$c>= :: Source -> Source -> Bool
>= :: Source -> Source -> Bool
$cmax :: Source -> Source -> Source
max :: Source -> Source -> Source
$cmin :: Source -> Source -> Source
min :: Source -> Source -> Source
Ord, Int -> Source -> ShowS
[Source] -> ShowS
Source -> String
(Int -> Source -> ShowS)
-> (Source -> String) -> ([Source] -> ShowS) -> Show Source
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Source -> ShowS
showsPrec :: Int -> Source -> ShowS
$cshow :: Source -> String
show :: Source -> String
$cshowList :: [Source] -> ShowS
showList :: [Source] -> ShowS
Show)

{- | A coherent cache entry: the parsed 'PackageInfo' paired with the raw 'Value' it
was decoded from. A hit returns both, so a caller gets a typed view to decide over
and the exact bytes that produced it: the packument serve path edits the raw 'Value'
in place and must keep its typed decision coherent with those bytes.
-}
data CacheEntry = CacheEntry
    { CacheEntry -> PackageInfo
entryInfo :: PackageInfo
    -- ^ The typed packument view the rules and merge reason over.
    , CacheEntry -> Value
entryRaw :: Value
    -- ^ The raw upstream document the served body is built from, edited in place.
    , CacheEntry -> ContentDigest
entryDigest :: ContentDigest
    {- ^ Digest of the wire bytes both views were decoded from, computed once at the
    leader's fetch -- the public origin's contribution to the serve path's derived
    ETag, amortised across every hit on this entry.
    -}
    }
    deriving stock (CacheEntry -> CacheEntry -> Bool
(CacheEntry -> CacheEntry -> Bool)
-> (CacheEntry -> CacheEntry -> Bool) -> Eq CacheEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CacheEntry -> CacheEntry -> Bool
== :: CacheEntry -> CacheEntry -> Bool
$c/= :: CacheEntry -> CacheEntry -> Bool
/= :: CacheEntry -> CacheEntry -> Bool
Eq, Int -> CacheEntry -> ShowS
[CacheEntry] -> ShowS
CacheEntry -> String
(Int -> CacheEntry -> ShowS)
-> (CacheEntry -> String)
-> ([CacheEntry] -> ShowS)
-> Show CacheEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CacheEntry -> ShowS
showsPrec :: Int -> CacheEntry -> ShowS
$cshow :: CacheEntry -> String
show :: CacheEntry -> String
$cshowList :: [CacheEntry] -> ShowS
showList :: [CacheEntry] -> ShowS
Show)

{- | Estimate a 'CacheEntry'\'s resident footprint in bytes as a fixed multiple of its raw
document's compact-encoded byte length. The resident cost (the parsed 'PackageInfo' plus the
raw 'Value') is a near-constant multiple of the document's size, so re-encoding the raw
'Value' and scaling it estimates the footprint without measuring the parsed structure. The
encode is an @O(document)@ pass run only on a leader's insert (the cold path after a fetch),
never on a hit. The multiplier is set at the high end of the observed resident-to-encoded
ratio so the estimate is an upper bound: a memory budget must not systematically under-count.
-}
weighCacheEntry :: CacheEntry -> Int
weighCacheEntry :: CacheEntry -> Int
weighCacheEntry CacheEntry
e = Int64 -> Int
weighEncodedBytes (ByteString -> Int64
BSL.length (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (CacheEntry -> Value
entryRaw CacheEntry
e)))

{- | Estimate a single-version entry's resident footprint in bytes. A present version's
'PackageDetails' is a single bounded manifest, so it is weighted at a flat per-version
figure; a cached determined absence (a negative entry) carries only a small fixed overhead.
The single-version store holds no raw document, so its weight is a fixed estimate rather than
an encoded-size multiple.
-}
weighVersion :: Maybe PackageDetails -> Int
weighVersion :: Maybe PackageDetails -> Int
weighVersion = \case
    Just PackageDetails
_ -> Int
versionEntryBytes
    Maybe PackageDetails
Nothing -> Int
negativeEntryBytes

-- Scale a raw document's encoded byte length to an estimated resident footprint. The factor
-- is 7.5 (applied as a halved integer to stay in 'Int' arithmetic): it sits at the high end
-- of the measured resident-to-encoded ratio, so the estimate upper-bounds resident bytes and
-- the budget never under-counts (leaner documents are over-estimated, which only over-evicts).
weighEncodedBytes :: Int64 -> Int
weighEncodedBytes :: Int64 -> Int
weighEncodedBytes Int64
encodedLen = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
encodedLen Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
residentRatioNumerator Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
residentRatioDenominator)

residentRatioNumerator :: Int64
residentRatioNumerator :: Int64
residentRatioNumerator = Int64
15

residentRatioDenominator :: Int64
residentRatioDenominator :: Int64
residentRatioDenominator = Int64
2

-- The flat resident estimate for a present single-version entry (one bounded manifest) and
-- for a cached determined absence (a small negative entry).
versionEntryBytes :: Int
versionEntryBytes :: Int
versionEntryBytes = Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024

negativeEntryBytes :: Int
negativeEntryBytes :: Int
negativeEntryBytes = Int
1024

{- | An assembled entry's resident footprint __is__ its strict bytes (plus a small
constant for the key and spine): unlike a parsed 'CacheEntry' there is no expanded
structure to estimate, so the budget counts what is genuinely held.
-}
weighAssembled :: ByteString -> Int
weighAssembled :: ByteString -> Int
weighAssembled ByteString
bytes = ByteString -> Int
BS.length ByteString
bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
assembledEntryOverheadBytes

assembledEntryOverheadBytes :: Int
assembledEntryOverheadBytes :: Int
assembledEntryOverheadBytes = Int
256

{- | The key a 'CacheEntry' is cached under: the upstream 'Source' paired with the
package's identity, rendered to a stable 'Text'. The package identity is distinct
from a display name so two encodings of the same scoped package share one entry, and
the source dimension keeps distinct upstreams apart; equality and ordering match
@(Source, PackageName)@ identity (the @cache@ library needs a 'Hashable' key, which
the opaque 'PackageName' does not expose, so the identity is projected to this key
here rather than via an orphan instance).
-}
newtype CacheKey = CacheKey Text
    deriving stock (CacheKey -> CacheKey -> Bool
(CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool) -> Eq CacheKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CacheKey -> CacheKey -> Bool
== :: CacheKey -> CacheKey -> Bool
$c/= :: CacheKey -> CacheKey -> Bool
/= :: CacheKey -> CacheKey -> Bool
Eq, Eq CacheKey
Eq CacheKey =>
(CacheKey -> CacheKey -> Ordering)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> CacheKey)
-> (CacheKey -> CacheKey -> CacheKey)
-> Ord CacheKey
CacheKey -> CacheKey -> Bool
CacheKey -> CacheKey -> Ordering
CacheKey -> CacheKey -> CacheKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CacheKey -> CacheKey -> Ordering
compare :: CacheKey -> CacheKey -> Ordering
$c< :: CacheKey -> CacheKey -> Bool
< :: CacheKey -> CacheKey -> Bool
$c<= :: CacheKey -> CacheKey -> Bool
<= :: CacheKey -> CacheKey -> Bool
$c> :: CacheKey -> CacheKey -> Bool
> :: CacheKey -> CacheKey -> Bool
$c>= :: CacheKey -> CacheKey -> Bool
>= :: CacheKey -> CacheKey -> Bool
$cmax :: CacheKey -> CacheKey -> CacheKey
max :: CacheKey -> CacheKey -> CacheKey
$cmin :: CacheKey -> CacheKey -> CacheKey
min :: CacheKey -> CacheKey -> CacheKey
Ord, Int -> CacheKey -> ShowS
[CacheKey] -> ShowS
CacheKey -> String
(Int -> CacheKey -> ShowS)
-> (CacheKey -> String) -> ([CacheKey] -> ShowS) -> Show CacheKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CacheKey -> ShowS
showsPrec :: Int -> CacheKey -> ShowS
$cshow :: CacheKey -> String
show :: CacheKey -> String
$cshowList :: [CacheKey] -> ShowS
showList :: [CacheKey] -> ShowS
Show)
    deriving newtype (Eq CacheKey
Eq CacheKey =>
(Int -> CacheKey -> Int) -> (CacheKey -> Int) -> Hashable CacheKey
Int -> CacheKey -> Int
CacheKey -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> CacheKey -> Int
hashWithSalt :: Int -> CacheKey -> Int
$chash :: CacheKey -> Int
hash :: CacheKey -> Int
Hashable)

{- The @(source, package)@ identity rendered to a stable 'Text': the source's base URL
joined with the package's identity (not its display form). The shared prefix of both
cache keys -- the full-packument key is exactly this, the single-version key appends the
version -- so the two stores partition on the same source\/package identity. -}
keyText :: Source -> PackageName -> Text
keyText :: Source -> PackageName -> Text
keyText (Source Text
source) PackageName
name =
    Text
source
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\x1f"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
forall b a. (Show a, IsString b) => a -> b
show (PackageName -> Ecosystem
pkgEcosystem PackageName
name)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\x1f"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Scope -> Text) -> Maybe Scope -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Scope -> Text
renderScope (PackageName -> Maybe Scope
pkgNamespace PackageName
name)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\x1f"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ShortText -> Text
TS.toText (PackageName -> ShortText
pkgCanonical PackageName
name)

{- | Project a 'Source' and a 'PackageName' to their full-packument cache key (the
source's base URL joined with the package's identity, not its display form).
-}
cacheKey :: Source -> PackageName -> CacheKey
cacheKey :: Source -> PackageName -> CacheKey
cacheKey Source
source PackageName
name = Text -> CacheKey
CacheKey (Source -> PackageName -> Text
keyText Source
source PackageName
name)

{- | The key a single-version entry is cached under: the @(source, package)@ identity
'cacheKey' uses, with the rendered 'Version' appended -- so distinct versions of one
package hold distinct entries, and the version store partitions on the same source as the
full store.
-}
newtype VersionKey = VersionKey Text
    deriving stock (VersionKey -> VersionKey -> Bool
(VersionKey -> VersionKey -> Bool)
-> (VersionKey -> VersionKey -> Bool) -> Eq VersionKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionKey -> VersionKey -> Bool
== :: VersionKey -> VersionKey -> Bool
$c/= :: VersionKey -> VersionKey -> Bool
/= :: VersionKey -> VersionKey -> Bool
Eq, Eq VersionKey
Eq VersionKey =>
(VersionKey -> VersionKey -> Ordering)
-> (VersionKey -> VersionKey -> Bool)
-> (VersionKey -> VersionKey -> Bool)
-> (VersionKey -> VersionKey -> Bool)
-> (VersionKey -> VersionKey -> Bool)
-> (VersionKey -> VersionKey -> VersionKey)
-> (VersionKey -> VersionKey -> VersionKey)
-> Ord VersionKey
VersionKey -> VersionKey -> Bool
VersionKey -> VersionKey -> Ordering
VersionKey -> VersionKey -> VersionKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: VersionKey -> VersionKey -> Ordering
compare :: VersionKey -> VersionKey -> Ordering
$c< :: VersionKey -> VersionKey -> Bool
< :: VersionKey -> VersionKey -> Bool
$c<= :: VersionKey -> VersionKey -> Bool
<= :: VersionKey -> VersionKey -> Bool
$c> :: VersionKey -> VersionKey -> Bool
> :: VersionKey -> VersionKey -> Bool
$c>= :: VersionKey -> VersionKey -> Bool
>= :: VersionKey -> VersionKey -> Bool
$cmax :: VersionKey -> VersionKey -> VersionKey
max :: VersionKey -> VersionKey -> VersionKey
$cmin :: VersionKey -> VersionKey -> VersionKey
min :: VersionKey -> VersionKey -> VersionKey
Ord, Int -> VersionKey -> ShowS
[VersionKey] -> ShowS
VersionKey -> String
(Int -> VersionKey -> ShowS)
-> (VersionKey -> String)
-> ([VersionKey] -> ShowS)
-> Show VersionKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionKey -> ShowS
showsPrec :: Int -> VersionKey -> ShowS
$cshow :: VersionKey -> String
show :: VersionKey -> String
$cshowList :: [VersionKey] -> ShowS
showList :: [VersionKey] -> ShowS
Show)
    deriving newtype (Eq VersionKey
Eq VersionKey =>
(Int -> VersionKey -> Int)
-> (VersionKey -> Int) -> Hashable VersionKey
Int -> VersionKey -> Int
VersionKey -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> VersionKey -> Int
hashWithSalt :: Int -> VersionKey -> Int
$chash :: VersionKey -> Int
hash :: VersionKey -> Int
Hashable)

versionKey :: Source -> PackageName -> Version -> VersionKey
versionKey :: Source -> PackageName -> Version -> VersionKey
versionKey Source
source PackageName
name Version
version = Text -> VersionKey
VersionKey (Source -> PackageName -> Text
keyText Source
source PackageName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\x1f" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
renderVersion Version
version)

{- | A stored value paired with the bookkeeping the resident-byte budget and the
recency-aware eviction need: the value\'s estimated resident weight, fixed at insert, and
its last-access stamp, a per-entry cell bumped on each hit. The stamp lives outside the
STM store so a hit updates recency without writing the shared container, and eviction reads
it to pick the least-recently-used victim.
-}
data Weighted v = Weighted
    { forall v. Weighted v -> v
wValue :: v
    -- ^ The cached value.
    , forall v. Weighted v -> Int
wWeight :: Int
    -- ^ The value's estimated resident footprint in bytes, fixed at insert.
    , forall v. Weighted v -> IORef Word64
wStamp :: IORef Word64
    -- ^ The value's last-access stamp; bumped on every hit, read by eviction.
    }

{- | One TTL- and STM-backed store with the resident-byte budget, the entry-count bound,
and the in-flight map that gives single-flight: the shape both the full-packument and
single-version caches take, factored so the resolution machinery ('resolveSingleFlight') is
written once over either. Entries are wrapped in 'Weighted' so the byte budget and the
least-recently-used eviction have the weight and access stamp they need.
-}
data SingleFlight k v = SingleFlight
    { forall k v. SingleFlight k v -> Cache k (Weighted v)
sfStore :: Cache k (Weighted v)
    -- ^ The TTL- and STM-backed store (the @cache@ library), holding weighted values.
    , forall k v. SingleFlight k v -> Int
sfMaxEntries :: Int
    -- ^ The entry-count bound enforced on insert.
    , forall k v. SingleFlight k v -> Int
sfMaxBytes :: Int
    -- ^ The resident-byte budget enforced on insert.
    , forall k v. SingleFlight k v -> v -> Int
sfWeigh :: v -> Int
    -- ^ Estimate a value's resident footprint in bytes, fixed into its 'Weighted' at insert.
    , forall k v. SingleFlight k v -> IORef Word64
sfClock :: IORef Word64
    {- ^ The store's logical access clock, bumped to issue each entry's recency stamp on
    insert and on every hit.
    -}
    , forall k v.
SingleFlight k v -> TVar (Map k (TMVar (Either SomeException v)))
sfInFlight :: TVar (Map k (TMVar (Either SomeException v)))
    {- ^ Entries currently being fetched, so concurrent misses coalesce onto one
    fetch rather than each launching their own.
    -}
    }

-- Build a 'SingleFlight' store from the cache configuration and a value weigher. The TTL is
-- converted to the @cache@ library's monotonic 'TimeSpec'; the access clock starts at zero
-- and the in-flight map empty.
newSingleFlight :: CacheConfig -> (v -> Int) -> IO (SingleFlight k v)
newSingleFlight :: forall v k. CacheConfig -> (v -> Int) -> IO (SingleFlight k v)
newSingleFlight CacheConfig
cfg v -> Int
weigh = do
    store <- Maybe TimeSpec -> IO (Cache k (Weighted v))
forall k v. Maybe TimeSpec -> IO (Cache k v)
Cache.newCache (TimeSpec -> Maybe TimeSpec
forall a. a -> Maybe a
Just (NominalDiffTime -> TimeSpec
toTimeSpec (CacheConfig -> NominalDiffTime
cacheTtl CacheConfig
cfg)))
    clock <- newIORef 0
    inFlight <- newTVarIO Map.empty
    pure
        SingleFlight
            { sfStore = store
            , sfMaxEntries = max 1 (cacheMaxEntries cfg)
            , sfMaxBytes = max 1 (cacheMaxBytes cfg)
            , sfWeigh = weigh
            , sfClock = clock
            , sfInFlight = inFlight
            }

{- | The metadata-cache handle: the three single-flight stores (the full-packument
cache, the single-version cache, and the assembled-representation store). Opaque:
built with 'newMetadataCache' and reached only through the accessors. Lives in the
composition root (one per process), so every request shares the same caches and their
connection-collapsing.
-}
data MetadataCache = MetadataCache
    { MetadataCache -> SingleFlight CacheKey CacheEntry
mcFull :: SingleFlight CacheKey CacheEntry
    -- ^ The full-packument store, keyed by @(source, package)@.
    , MetadataCache -> SingleFlight VersionKey (Maybe PackageDetails)
mcVersion :: SingleFlight VersionKey (Maybe PackageDetails)
    {- ^ The single-version store, keyed by @(source, package, version)@, holding one
    version's 'PackageDetails' (or its determined absence), written only by the
    single-version path, never the full path.
    -}
    , MetadataCache -> SingleFlight Text ByteString
mcAssembled :: SingleFlight Text ByteString
    {- ^ The assembled-representation store: the encoded served document, keyed by its
    derived validator's rendered form (a content address over every serve input; see
    the module header), written and read only by the packument serve tail.
    -}
    }

{- | Build a metadata cache from its configuration: the full-packument store, the
single-version store, and the assembled-representation store, each over the same TTL
and size bound.
-}
newMetadataCache :: CacheConfig -> IO MetadataCache
newMetadataCache :: CacheConfig -> IO MetadataCache
newMetadataCache CacheConfig
cfg =
    SingleFlight CacheKey CacheEntry
-> SingleFlight VersionKey (Maybe PackageDetails)
-> SingleFlight Text ByteString
-> MetadataCache
MetadataCache
        (SingleFlight CacheKey CacheEntry
 -> SingleFlight VersionKey (Maybe PackageDetails)
 -> SingleFlight Text ByteString
 -> MetadataCache)
-> IO (SingleFlight CacheKey CacheEntry)
-> IO
     (SingleFlight VersionKey (Maybe PackageDetails)
      -> SingleFlight Text ByteString -> MetadataCache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CacheConfig
-> (CacheEntry -> Int) -> IO (SingleFlight CacheKey CacheEntry)
forall v k. CacheConfig -> (v -> Int) -> IO (SingleFlight k v)
newSingleFlight CacheConfig
cfg CacheEntry -> Int
weighCacheEntry
        IO
  (SingleFlight VersionKey (Maybe PackageDetails)
   -> SingleFlight Text ByteString -> MetadataCache)
-> IO (SingleFlight VersionKey (Maybe PackageDetails))
-> IO (SingleFlight Text ByteString -> MetadataCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CacheConfig
-> (Maybe PackageDetails -> Int)
-> IO (SingleFlight VersionKey (Maybe PackageDetails))
forall v k. CacheConfig -> (v -> Int) -> IO (SingleFlight k v)
newSingleFlight CacheConfig
cfg Maybe PackageDetails -> Int
weighVersion
        IO (SingleFlight Text ByteString -> MetadataCache)
-> IO (SingleFlight Text ByteString) -> IO MetadataCache
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CacheConfig
-> (ByteString -> Int) -> IO (SingleFlight Text ByteString)
forall v k. CacheConfig -> (v -> Int) -> IO (SingleFlight k v)
newSingleFlight CacheConfig
cfg ByteString -> Int
weighAssembled

{- | Resolve a package's metadata from one upstream 'Source', reusing the cache and
collapsing concurrent misses.

On a fresh, unexpired hit the cached 'CacheEntry' is returned and the fetch action
is never run. On a miss the action runs exactly once even under concurrent callers:
the first installs an in-flight marker and fetches, the others wait on its result.
A successful fetch is cached (subject to the TTL and size bound); a failed fetch
caches __nothing__ (so a transient upstream error does not poison the cache) and is
re-raised to every waiter.

A claimed in-flight slot is __always eventually filled and de-registered__, even if
the leader is hit by an async exception (a request timeout, a killed handler thread)
between claiming the slot and completing: the claim commits under a 'mask' and the
leader's run is handed straight to 'Ecluse.Core.InFlight.guardInFlight', which frees the
slot on every exit and, on any exception before the marker is filled, hands that error
to every waiting follower rather than leaving them parked forever. This closes the
single-flight orphan window (without it, a cancelled leader would wedge that
@(source, package)@ key until restart). A follower's own wait on the marker stays
interruptible.

The 'Source' partitions the cache: distinct upstreams of the same package resolve
under distinct keys and never cross-contaminate. The fetch action supplies the origin's
own credential, so reading through one source never blurs another's trust posture.
Under the default @passthrough@ strategy only the anonymous public origin is resolved
here: the trusted private origin is the per-client authority and is fetched per request,
never cached, so a shared entry can never serve one client another's private document.

The result is always re-decided by the caller's rules on each request -- only the
fetch+parse is memoised, never the verdict.

Each resolution records the @ecluse.metadata_cache.requests@ hit\/miss counter (a
coalescing follower counts as a miss, like the leader it waits on), and a leader's
insert refreshes the @ecluse.metadata_cache.entries@ occupancy gauge and the
@ecluse.metadata_cache.resident_bytes@ residency gauge.
-}
resolveMetadata :: MetricsPort -> MetadataCache -> Source -> PackageName -> IO CacheEntry -> IO CacheEntry
resolveMetadata :: MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> IO CacheEntry
-> IO CacheEntry
resolveMetadata = IO ()
-> MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> IO CacheEntry
-> IO CacheEntry
resolveMetadataWith (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

{- | As 'resolveMetadata', but with a hook run on the leading thread at the
single-flight claim → fetch-runner handoff: the window between the STM transaction
committing the in-flight claim and the leader's exception guard taking ownership of
the marker. It exists only so a test can deterministically park a leader in that
window and cancel it there, exercising the orphan-window guarantee; production always
passes @pure ()@ via 'resolveMetadata'.
-}
resolveMetadataWith :: IO () -> MetricsPort -> MetadataCache -> Source -> PackageName -> IO CacheEntry -> IO CacheEntry
resolveMetadataWith :: IO ()
-> MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> IO CacheEntry
-> IO CacheEntry
resolveMetadataWith IO ()
afterClaim MetricsPort
metrics MetadataCache
cache Source
source PackageName
name =
    IO ()
-> (CacheResult -> IO ())
-> (CacheOccupancy -> IO ())
-> SingleFlight CacheKey CacheEntry
-> CacheKey
-> IO CacheEntry
-> IO CacheEntry
forall k v.
(Hashable k, Ord k) =>
IO ()
-> (CacheResult -> IO ())
-> (CacheOccupancy -> IO ())
-> SingleFlight k v
-> k
-> IO v
-> IO v
resolveSingleFlight
        IO ()
afterClaim
        (MetricsPort -> CacheResult -> IO ()
mpCacheRequest MetricsPort
metrics)
        ( \CacheOccupancy
occ -> do
            MetricsPort -> Int -> IO ()
mpCacheEntries MetricsPort
metrics (CacheOccupancy -> Int
occEntries CacheOccupancy
occ)
            MetricsPort -> Int -> IO ()
mpCacheResidentBytes MetricsPort
metrics (CacheOccupancy -> Int
occBytes CacheOccupancy
occ)
        )
        (MetadataCache -> SingleFlight CacheKey CacheEntry
mcFull MetadataCache
cache)
        (Source -> PackageName -> CacheKey
cacheKey Source
source PackageName
name)

{- | Resolve __one version's__ 'PackageDetails' (or its determined absence) from the
single-version cache, leading a selective fetch on a miss and collapsing concurrent misses
exactly as 'resolveMetadata' does for the full packument. The cached value is the
@'Maybe' 'PackageDetails'@ the fetch yields, so a version determined __absent__ over sound
metadata is cached as 'Nothing' (a negative entry) and re-served without a re-fetch within
the TTL.

This writes to the single-version store only, never the full-packument store, so a cold
tarball gate's selective parse cannot materialise a whole packument into the shared full
cache. Unlike 'resolveMetadata', the single-version store records no hit\/miss counter; a
leader's insert does refresh the single-version residency gauge
(@ecluse.metadata_cache.version.resident_bytes@), so the byte budget that bounds both
stores is observable on each.
-}
resolveVersion :: MetricsPort -> MetadataCache -> Source -> PackageName -> Version -> IO (Maybe PackageDetails) -> IO (Maybe PackageDetails)
resolveVersion :: MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> Version
-> IO (Maybe PackageDetails)
-> IO (Maybe PackageDetails)
resolveVersion = IO ()
-> MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> Version
-> IO (Maybe PackageDetails)
-> IO (Maybe PackageDetails)
resolveVersionWith (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

{- | As 'resolveVersion', with the single-flight claim → fetch-runner handoff hook
'resolveMetadataWith' exposes, for the same orphan-window test (production passes @pure ()@
via 'resolveVersion').
-}
resolveVersionWith :: IO () -> MetricsPort -> MetadataCache -> Source -> PackageName -> Version -> IO (Maybe PackageDetails) -> IO (Maybe PackageDetails)
resolveVersionWith :: IO ()
-> MetricsPort
-> MetadataCache
-> Source
-> PackageName
-> Version
-> IO (Maybe PackageDetails)
-> IO (Maybe PackageDetails)
resolveVersionWith IO ()
afterClaim MetricsPort
metrics MetadataCache
cache Source
source PackageName
name Version
version =
    IO ()
-> (CacheResult -> IO ())
-> (CacheOccupancy -> IO ())
-> SingleFlight VersionKey (Maybe PackageDetails)
-> VersionKey
-> IO (Maybe PackageDetails)
-> IO (Maybe PackageDetails)
forall k v.
(Hashable k, Ord k) =>
IO ()
-> (CacheResult -> IO ())
-> (CacheOccupancy -> IO ())
-> SingleFlight k v
-> k
-> IO v
-> IO v
resolveSingleFlight
        IO ()
afterClaim
        (IO () -> CacheResult -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass)
        (MetricsPort -> Int -> IO ()
mpVersionCacheResidentBytes MetricsPort
metrics (Int -> IO ())
-> (CacheOccupancy -> Int) -> CacheOccupancy -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheOccupancy -> Int
occBytes)
        (MetadataCache -> SingleFlight VersionKey (Maybe PackageDetails)
mcVersion MetadataCache
cache)
        (Source -> PackageName -> Version -> VersionKey
versionKey Source
source PackageName
name Version
version)

{- | Resolve the __assembled representation__ for one derived validator, leading the
render (assemble + encode) on a miss and collapsing concurrent identical renders,
exactly as 'resolveMetadata' does for a fetch.

The key is the rendered derived 'Ecluse.Core.Server.Conditional.ETag' -- a content
address over every input the served document is a function of -- so a hit is
byte-for-byte the document this request's own inputs would deterministically produce:
the store can never serve stale bytes (changed inputs miss by construction) and never
crosses a client boundary (a different private view is a different key; see the
module header). Under the TTL-zero configuration the store degrades to pure
single-flight coalescing, the same behaviour as the sibling stores.

Like the single-version store it records no hit\/miss counter; a leader's insert
refreshes the @ecluse.metadata_cache.assembled.resident_bytes@ residency gauge, so
the byte budget's third occupant is observable alongside the other two.
-}
resolveAssembled :: MetricsPort -> MetadataCache -> Text -> IO ByteString -> IO ByteString
resolveAssembled :: MetricsPort
-> MetadataCache -> Text -> IO ByteString -> IO ByteString
resolveAssembled MetricsPort
metrics MetadataCache
cache =
    IO ()
-> (CacheResult -> IO ())
-> (CacheOccupancy -> IO ())
-> SingleFlight Text ByteString
-> Text
-> IO ByteString
-> IO ByteString
forall k v.
(Hashable k, Ord k) =>
IO ()
-> (CacheResult -> IO ())
-> (CacheOccupancy -> IO ())
-> SingleFlight k v
-> k
-> IO v
-> IO v
resolveSingleFlight
        (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        (IO () -> CacheResult -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass)
        (MetricsPort -> Int -> IO ()
mpAssembledCacheResidentBytes MetricsPort
metrics (Int -> IO ())
-> (CacheOccupancy -> Int) -> CacheOccupancy -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheOccupancy -> Int
occBytes)
        (MetadataCache -> SingleFlight Text ByteString
mcAssembled MetadataCache
cache)

{- The single-flight resolution shared by the full-packument and single-version caches: a
fresh hit short-circuits; otherwise the caller leads one fetch (installing an in-flight
marker) or follows an in-flight one. @recordRequest@ records the hit\/miss counter (or
ignores it) and @recordInsert@ refreshes the occupancy gauges from the post-insert
'CacheOccupancy' after a leader insert (or ignores it), so each store wires its own
telemetry without the resolution logic knowing which it serves.

A hit bumps the entry's recency stamp before returning it, done in plain 'IO' so recency is
updated without writing the shared STM store (and so a hit never contends with a concurrent
resolution). On a miss the fetch runs exactly once even under concurrent callers; a
successful fetch is cached (subject to the TTL, the entry-count bound, and the resident-byte
budget), a failed fetch caches __nothing__ and is re-raised to every waiter. A claimed slot
is __always eventually filled and de-registered__ even under an async exception in the
claim → runner window: the claim commits under a 'mask' and the run is handed straight to
'Ecluse.Core.InFlight.guardInFlight', which frees the slot on every exit and hands the
orphaning error to any waiting follower (closing the single-flight orphan window). A
follower's own wait stays interruptible. The result is inserted __before__ the slot is
de-registered, so a caller arriving the instant the fetch returns becomes a follower rather
than re-leading a redundant fetch. -}
resolveSingleFlight ::
    (Hashable k, Ord k) =>
    IO () ->
    (Metric.CacheResult -> IO ()) ->
    (CacheOccupancy -> IO ()) ->
    SingleFlight k v ->
    k ->
    IO v ->
    IO v
resolveSingleFlight :: forall k v.
(Hashable k, Ord k) =>
IO ()
-> (CacheResult -> IO ())
-> (CacheOccupancy -> IO ())
-> SingleFlight k v
-> k
-> IO v
-> IO v
resolveSingleFlight IO ()
afterClaim CacheResult -> IO ()
recordRequest CacheOccupancy -> IO ()
recordInsert SingleFlight k v
sf k
key IO v
fetch = ((forall a. IO a -> IO a) -> IO v) -> IO v
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO v) -> IO v)
-> ((forall a. IO a -> IO a) -> IO v) -> IO v
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    nowT <- Clock -> IO TimeSpec
getTime Clock
Monotonic
    -- One atomic decision point under the enclosing 'mask': a 'Hit' or 'Follow' claims
    -- nothing (its wait runs under @restore@, interruptible); a 'Lead' installs the marker
    -- and hands the run to 'guardInFlight' with no interruptible point between.
    decision <- atomically (decideSingleFlight sf key nowT)
    case decision of
        Hit Weighted v
weighted -> do
            CacheResult -> IO ()
recordRequest CacheResult
Metric.Hit
            -- Bump recency outside the STM transaction: a hit updates the per-entry stamp
            -- without writing the shared store, so the least-recently-used eviction sees it.
            SingleFlight k v -> Weighted v -> IO ()
forall k v. SingleFlight k v -> Weighted v -> IO ()
touch SingleFlight k v
sf Weighted v
weighted
            v -> IO v
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Weighted v -> v
forall v. Weighted v -> v
wValue Weighted v
weighted)
        Follow TMVar (Either SomeException v)
marker -> do
            -- A follower coalesced onto an in-flight fetch is a miss for this caller
            -- (no fresh entry was present), exactly as the leader's miss is.
            CacheResult -> IO ()
recordRequest CacheResult
Metric.Miss
            result <- IO (Either SomeException v) -> IO (Either SomeException v)
forall a. IO a -> IO a
restore (STM (Either SomeException v) -> IO (Either SomeException v)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Either SomeException v) -> STM (Either SomeException v)
forall a. TMVar a -> STM a
readTMVar TMVar (Either SomeException v)
marker))
            case result of
                Right v
fetched -> v -> IO v
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
fetched
                Left SomeException
err -> case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
                    Just (SomeAsyncException
_ :: SomeAsyncException) ->
                        -- The leader was killed (e.g. by a client disconnect). We must
                        -- re-evaluate the single-flight decision rather than dying with it.
                        IO ()
-> (CacheResult -> IO ())
-> (CacheOccupancy -> IO ())
-> SingleFlight k v
-> k
-> IO v
-> IO v
forall k v.
(Hashable k, Ord k) =>
IO ()
-> (CacheResult -> IO ())
-> (CacheOccupancy -> IO ())
-> SingleFlight k v
-> k
-> IO v
-> IO v
resolveSingleFlight IO ()
afterClaim CacheResult -> IO ()
recordRequest CacheOccupancy -> IO ()
recordInsert SingleFlight k v
sf k
key IO v
fetch
                    Maybe SomeAsyncException
Nothing -> SomeException -> IO v
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
err
        Lead TMVar (Either SomeException v)
marker -> do
            CacheResult -> IO ()
recordRequest CacheResult
Metric.Miss
            -- Only the fetch runs under @restore@ (cancellable); the publish + insert run
            -- under the enclosing 'mask' so a cancel after the fetch returns still delivers
            -- and inserts. 'guardInFlight' is passed 'id'; it frees the slot on every exit
            -- and, on a failure before the marker is filled, hands the error to followers
            -- via 'orphan'. The insert precedes de-registration, so "collapse to one fetch"
            -- holds even for a caller arriving the instant the fetch returns.
            (entry, occupancy) <- (IO (v, CacheOccupancy) -> IO (v, CacheOccupancy))
-> (SomeException -> IO ())
-> IO ()
-> IO (v, CacheOccupancy)
-> IO (v, CacheOccupancy)
forall a.
(IO a -> IO a) -> (SomeException -> IO ()) -> IO () -> IO a -> IO a
guardInFlight IO (v, CacheOccupancy) -> IO (v, CacheOccupancy)
forall a. a -> a
id (TMVar (Either SomeException v) -> SomeException -> IO ()
forall v. TMVar (Either SomeException v) -> SomeException -> IO ()
orphan TMVar (Either SomeException v)
marker) (STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM ()
deregister) (IO (v, CacheOccupancy) -> IO (v, CacheOccupancy))
-> IO (v, CacheOccupancy) -> IO (v, CacheOccupancy)
forall a b. (a -> b) -> a -> b
$ do
                fetched <- IO v -> IO v
forall a. IO a -> IO a
restore (IO ()
afterClaim IO () -> IO v -> IO v
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO v
fetch)
                atomically (putTMVar marker (Right fetched))
                occupancy <- insertBounded sf key fetched
                pure (fetched, occupancy)
            -- The leader inserted, so refresh the occupancy gauges (a follower never does).
            recordInsert occupancy
            pure entry
  where
    deregister :: STM ()
    deregister :: STM ()
deregister = do
        inFlight <- TVar (Map k (TMVar (Either SomeException v)))
-> STM (Map k (TMVar (Either SomeException v)))
forall a. TVar a -> STM a
readTVar (SingleFlight k v -> TVar (Map k (TMVar (Either SomeException v)))
forall k v.
SingleFlight k v -> TVar (Map k (TMVar (Either SomeException v)))
sfInFlight SingleFlight k v
sf)
        writeTVar (sfInFlight sf) (Map.delete key inFlight)

{- | Insert a freshly fetched value into a store, enforcing the resident-byte budget and the
entry-count bound. Expired entries are purged first (the cheap reclaim); then the
least-recently-used entries are evicted until the incoming value fits within both bounds,
and the value is inserted with its estimated weight and a fresh recency stamp. The incoming
value is __always admitted__: a single value larger than the whole budget becomes the sole
resident rather than being refused (the per-value ceiling is the upstream body cap, not this
budget). Returns the store's occupancy after the insert, for the residency telemetry.
-}
insertBounded :: (Hashable k) => SingleFlight k v -> k -> v -> IO CacheOccupancy
insertBounded :: forall k v.
Hashable k =>
SingleFlight k v -> k -> v -> IO CacheOccupancy
insertBounded SingleFlight k v
sf k
key v
value = do
    Cache k (Weighted v) -> IO ()
forall k v. (Eq k, Hashable k) => Cache k v -> IO ()
Cache.purgeExpired (SingleFlight k v -> Cache k (Weighted v)
forall k v. SingleFlight k v -> Cache k (Weighted v)
sfStore SingleFlight k v
sf)
    let weight :: Int
weight = SingleFlight k v -> v -> Int
forall k v. SingleFlight k v -> v -> Int
sfWeigh SingleFlight k v
sf v
value
    SingleFlight k v -> Int -> IO ()
forall k v. Hashable k => SingleFlight k v -> Int -> IO ()
evictToBudget SingleFlight k v
sf Int
weight
    stamp <- SingleFlight k v -> IO Word64
forall k v. SingleFlight k v -> IO Word64
nextStamp SingleFlight k v
sf
    stampRef <- newIORef stamp
    Cache.insert (sfStore sf) key (Weighted{wValue = value, wWeight = weight, wStamp = stampRef})
    occupancyOf sf

{- | Evict least-recently-used entries until an incoming value of the given weight would fit
within both the resident-byte budget and the entry-count bound, or the store is empty. The
store is scanned, entries are ordered by ascending recency stamp (oldest first), and the
coldest are dropped one at a time until @resident + incoming@ is within the budget and the
count leaves room for one more. Reaching an empty store stops the sweep, so the incoming
value is always admitted afterwards. The scan runs only on a leader's insert (the cold path
after a fetch), so iterating the held entries is off the hot path.
-}
evictToBudget :: (Hashable k) => SingleFlight k v -> Int -> IO ()
evictToBudget :: forall k v. Hashable k => SingleFlight k v -> Int -> IO ()
evictToBudget SingleFlight k v
sf Int
incoming = do
    held <- Cache k (Weighted v) -> IO [(k, Weighted v, Maybe TimeSpec)]
forall k v. Cache k v -> IO [(k, v, Maybe TimeSpec)]
Cache.toList (SingleFlight k v -> Cache k (Weighted v)
forall k v. SingleFlight k v -> Cache k (Weighted v)
sfStore SingleFlight k v
sf)
    stamped <- traverse stampOf held
    let resident = [Int] -> Int
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum [Weighted v -> Int
forall v. Weighted v -> Int
wWeight Weighted v
w | (k
_, Weighted v
w, Maybe TimeSpec
_) <- [(k, Weighted v, Maybe TimeSpec)]
held]
        oldestFirst = ((Word64, k, Int) -> Word64)
-> [(Word64, k, Int)] -> [(Word64, k, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Word64
stamp, k
_, Int
_) -> Word64
stamp) [(Word64, k, Int)]
stamped
    go oldestFirst resident (length held)
  where
    stampOf :: (b, Weighted v, c) -> m (Word64, b, Int)
stampOf (b
k, Weighted v
w, c
_) = do
        s <- IORef Word64 -> m Word64
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (Weighted v -> IORef Word64
forall v. Weighted v -> IORef Word64
wStamp Weighted v
w)
        pure (s, k, wWeight w)

    fits :: Int -> Int -> Bool
fits Int
resident Int
count = Int
resident Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
incoming Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= SingleFlight k v -> Int
forall k v. SingleFlight k v -> Int
sfMaxBytes SingleFlight k v
sf Bool -> Bool -> Bool
&& Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< SingleFlight k v -> Int
forall k v. SingleFlight k v -> Int
sfMaxEntries SingleFlight k v
sf

    go :: [(a, k, Int)] -> Int -> Int -> IO ()
go [(a, k, Int)]
victims Int
resident Int
count
        | Int -> Int -> Bool
fits Int
resident Int
count = IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        | Bool
otherwise = case [(a, k, Int)]
victims of
            [] -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
            ((a
_, k
k, Int
weight) : [(a, k, Int)]
rest) -> do
                Cache k (Weighted v) -> k -> IO ()
forall k v. (Eq k, Hashable k) => Cache k v -> k -> IO ()
Cache.delete (SingleFlight k v -> Cache k (Weighted v)
forall k v. SingleFlight k v -> Cache k (Weighted v)
sfStore SingleFlight k v
sf) k
k
                [(a, k, Int)] -> Int -> Int -> IO ()
go [(a, k, Int)]
rest (Int
resident Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
weight) (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- The store's occupancy after an insert: the entry count and the summed resident weight of
-- the held entries, the values the residency telemetry reports.
occupancyOf :: SingleFlight k v -> IO CacheOccupancy
occupancyOf :: forall k v. SingleFlight k v -> IO CacheOccupancy
occupancyOf SingleFlight k v
sf = do
    held <- Cache k (Weighted v) -> IO [(k, Weighted v, Maybe TimeSpec)]
forall k v. Cache k v -> IO [(k, v, Maybe TimeSpec)]
Cache.toList (SingleFlight k v -> Cache k (Weighted v)
forall k v. SingleFlight k v -> Cache k (Weighted v)
sfStore SingleFlight k v
sf)
    pure CacheOccupancy{occEntries = length held, occBytes = sum [wWeight w | (_, w, _) <- held]}

-- Issue the next logical access stamp from the store's clock: a strictly increasing
-- 'Word64', so a larger stamp is unambiguously more recent.
nextStamp :: SingleFlight k v -> IO Word64
nextStamp :: forall k v. SingleFlight k v -> IO Word64
nextStamp SingleFlight k v
sf = IORef Word64 -> (Word64 -> (Word64, Word64)) -> IO Word64
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (SingleFlight k v -> IORef Word64
forall k v. SingleFlight k v -> IORef Word64
sfClock SingleFlight k v
sf) (\Word64
n -> let n' :: Word64
n' = Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1 in (Word64
n', Word64
n'))

-- Bump a held entry's recency to the current logical time, marking it most-recently-used.
-- Runs in plain 'IO' (never STM), so a hit refreshes recency without writing the store.
touch :: SingleFlight k v -> Weighted v -> IO ()
touch :: forall k v. SingleFlight k v -> Weighted v -> IO ()
touch SingleFlight k v
sf Weighted v
weighted = SingleFlight k v -> IO Word64
forall k v. SingleFlight k v -> IO Word64
nextStamp SingleFlight k v
sf IO Word64 -> (Word64 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef Word64 -> Word64 -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef (Weighted v -> IORef Word64
forall v. Weighted v -> IORef Word64
wStamp Weighted v
weighted)

{- | Look up a package's cached full-packument entry for one 'Source' without fetching on a
miss: the cache's read-only view, for inspection and tests. A 'Nothing' is a miss or an
expired entry; this never triggers a fetch and never collapses (use 'resolveMetadata' for
the serve path).
-}
cachedMetadata :: MetadataCache -> Source -> PackageName -> IO (Maybe CacheEntry)
cachedMetadata :: MetadataCache -> Source -> PackageName -> IO (Maybe CacheEntry)
cachedMetadata MetadataCache
cache Source
source PackageName
name = (Weighted CacheEntry -> CacheEntry)
-> Maybe (Weighted CacheEntry) -> Maybe CacheEntry
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Weighted CacheEntry -> CacheEntry
forall v. Weighted v -> v
wValue (Maybe (Weighted CacheEntry) -> Maybe CacheEntry)
-> IO (Maybe (Weighted CacheEntry)) -> IO (Maybe CacheEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cache CacheKey (Weighted CacheEntry)
-> CacheKey -> IO (Maybe (Weighted CacheEntry))
forall k v. (Eq k, Hashable k) => Cache k v -> k -> IO (Maybe v)
Cache.lookup (SingleFlight CacheKey CacheEntry
-> Cache CacheKey (Weighted CacheEntry)
forall k v. SingleFlight k v -> Cache k (Weighted v)
sfStore (MetadataCache -> SingleFlight CacheKey CacheEntry
mcFull MetadataCache
cache)) (Source -> PackageName -> CacheKey
cacheKey Source
source PackageName
name)

{- | Look up a single-version cached entry for one @(source, package, version)@ without
fetching on a miss: the version store's read-only view (the hybrid serve path's negative\/
positive lookup before it leads a selective fetch). The outer 'Maybe' is the cache hit\/miss
(an expired or absent entry is 'Nothing'); the inner @'Maybe' 'PackageDetails'@ is the
cached result (a version determined absent is a cached @'Just' 'Nothing'@).
-}
cachedVersion :: MetadataCache -> Source -> PackageName -> Version -> IO (Maybe (Maybe PackageDetails))
cachedVersion :: MetadataCache
-> Source
-> PackageName
-> Version
-> IO (Maybe (Maybe PackageDetails))
cachedVersion MetadataCache
cache Source
source PackageName
name Version
version = (Weighted (Maybe PackageDetails) -> Maybe PackageDetails)
-> Maybe (Weighted (Maybe PackageDetails))
-> Maybe (Maybe PackageDetails)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Weighted (Maybe PackageDetails) -> Maybe PackageDetails
forall v. Weighted v -> v
wValue (Maybe (Weighted (Maybe PackageDetails))
 -> Maybe (Maybe PackageDetails))
-> IO (Maybe (Weighted (Maybe PackageDetails)))
-> IO (Maybe (Maybe PackageDetails))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cache VersionKey (Weighted (Maybe PackageDetails))
-> VersionKey -> IO (Maybe (Weighted (Maybe PackageDetails)))
forall k v. (Eq k, Hashable k) => Cache k v -> k -> IO (Maybe v)
Cache.lookup (SingleFlight VersionKey (Maybe PackageDetails)
-> Cache VersionKey (Weighted (Maybe PackageDetails))
forall k v. SingleFlight k v -> Cache k (Weighted v)
sfStore (MetadataCache -> SingleFlight VersionKey (Maybe PackageDetails)
mcVersion MetadataCache
cache)) (Source -> PackageName -> Version -> VersionKey
versionKey Source
source PackageName
name Version
version)

-- | The number of full-packument entries currently held (including any not-yet-purged expired).
cacheSize :: MetadataCache -> IO Int
cacheSize :: MetadataCache -> IO Int
cacheSize MetadataCache
cache = Cache CacheKey (Weighted CacheEntry) -> IO Int
forall k v. Cache k v -> IO Int
Cache.size (SingleFlight CacheKey CacheEntry
-> Cache CacheKey (Weighted CacheEntry)
forall k v. SingleFlight k v -> Cache k (Weighted v)
sfStore (MetadataCache -> SingleFlight CacheKey CacheEntry
mcFull MetadataCache
cache))

-- The outcome of the one atomic resolve decision: a fresh hit (carrying the weighted entry
-- so the caller can bump its recency), follow an in-flight fetch, or lead a new one.
data Decision v
    = Hit (Weighted v)
    | Follow (TMVar (Either SomeException v))
    | Lead (TMVar (Either SomeException v))

-- The one atomic resolve decision for a key: a fresh, unexpired hit wins; else follow the
-- key's in-flight fetch; else install an in-flight marker and lead. One STM transaction,
-- run inside 'resolveSingleFlight''s mask.
decideSingleFlight :: (Hashable k, Ord k) => SingleFlight k v -> k -> TimeSpec -> STM (Decision v)
decideSingleFlight :: forall k v.
(Hashable k, Ord k) =>
SingleFlight k v -> k -> TimeSpec -> STM (Decision v)
decideSingleFlight SingleFlight k v
sf k
key TimeSpec
nowT = do
    hit <- Bool
-> k
-> Cache k (Weighted v)
-> TimeSpec
-> STM (Maybe (Weighted v))
forall k v.
(Eq k, Hashable k) =>
Bool -> k -> Cache k v -> TimeSpec -> STM (Maybe v)
Cache.lookupSTM Bool
False k
key (SingleFlight k v -> Cache k (Weighted v)
forall k v. SingleFlight k v -> Cache k (Weighted v)
sfStore SingleFlight k v
sf) TimeSpec
nowT
    case hit of
        Just Weighted v
weighted -> Decision v -> STM (Decision v)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Weighted v -> Decision v
forall v. Weighted v -> Decision v
Hit Weighted v
weighted)
        Maybe (Weighted v)
Nothing -> do
            inFlight <- TVar (Map k (TMVar (Either SomeException v)))
-> STM (Map k (TMVar (Either SomeException v)))
forall a. TVar a -> STM a
readTVar (SingleFlight k v -> TVar (Map k (TMVar (Either SomeException v)))
forall k v.
SingleFlight k v -> TVar (Map k (TMVar (Either SomeException v)))
sfInFlight SingleFlight k v
sf)
            case Map.lookup key inFlight of
                Just TMVar (Either SomeException v)
marker -> Decision v -> STM (Decision v)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TMVar (Either SomeException v) -> Decision v
forall v. TMVar (Either SomeException v) -> Decision v
Follow TMVar (Either SomeException v)
marker)
                Maybe (TMVar (Either SomeException v))
Nothing -> do
                    marker <- STM (TMVar (Either SomeException v))
forall a. STM (TMVar a)
newEmptyTMVar
                    writeTVar (sfInFlight sf) (Map.insert key marker inFlight)
                    pure (Lead marker)

-- The orphan hand-off: a failure before the marker was filled. Fill it with the error
-- so blocked followers unblock rather than parking forever; 'guardInFlight' frees the
-- slot separately. Fills only when empty, so a failure after a successful publish never
-- clobbers the result.
orphan :: TMVar (Either SomeException v) -> SomeException -> IO ()
orphan :: forall v. TMVar (Either SomeException v) -> SomeException -> IO ()
orphan TMVar (Either SomeException v)
marker SomeException
err =
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        unfilled <- TMVar (Either SomeException v) -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar (Either SomeException v)
marker
        when unfilled (putTMVar marker (Left err))

-- A store's occupancy after a leader's insert: the held entry count and their summed
-- resident weight, the values the occupancy and residency gauges report.
data CacheOccupancy = CacheOccupancy
    { CacheOccupancy -> Int
occEntries :: Int
    , CacheOccupancy -> Int
occBytes :: Int
    }

-- Convert a 'NominalDiffTime' (seconds) to the @cache@ library's monotonic
-- 'TimeSpec' (whole seconds + nanoseconds), clamping a negative TTL to zero.
toTimeSpec :: NominalDiffTime -> TimeSpec
toTimeSpec :: NominalDiffTime -> TimeSpec
toTimeSpec NominalDiffTime
ttl =
    let nanos :: Integer
nanos = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
ttl Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e9 :: Double)) :: Integer
        billion :: Integer
billion = Integer
1000000000
     in Int64 -> Int64 -> TimeSpec
TimeSpec
            (Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer
nanos Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
billion))
            (Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer
nanos Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
billion))