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

-- | Shared local capacity and transactional maintenance of separately typed stores.
module Ecluse.Core.Server.Cache.Backend.Local.Internal (
    LocalPool,
    newLocalPool,
    newLocalPoolWithClock,
    registerStore,
    runPool,
    readPool,
    poolFits,
    adjustPool,
    poolEnabled,
    poolAcceptsWeight,
) where

import System.Clock (Clock (Monotonic), TimeSpec, getTime)
import UnliftIO.Exception (mask_)
import UnliftIO.MVar (withMVar)

import Ecluse.Core.Server.Cache.Backend (CacheOccupancy (..))

-- | The pool owns one aggregate counter. Registered actions hold no duplicate entry index.
data LocalPool = LocalPool
    { LocalPool -> Int
lpMaxEntries :: Int
    , LocalPool -> Int
lpMaxBytes :: Int
    , LocalPool -> TVar CacheOccupancy
lpOccupancy :: TVar CacheOccupancy
    , LocalPool -> TVar [StoreMaintenance]
lpStores :: TVar [StoreMaintenance]
    , LocalPool -> MVar ()
lpLock :: MVar ()
    , LocalPool -> IO TimeSpec
lpNow :: IO TimeSpec
    }

data StoreMaintenance = StoreMaintenance
    { StoreMaintenance -> STM (Maybe TimeSpec)
smDeadline :: STM (Maybe TimeSpec)
    , StoreMaintenance -> TimeSpec -> STM ()
smExpire :: TimeSpec -> STM ()
    , StoreMaintenance -> STM (CacheOccupancy, CacheOccupancy -> IO ())
smObserve :: STM (CacheOccupancy, CacheOccupancy -> IO ())
    }

-- | Build one aggregate bound for all registered local stores.
newLocalPool :: Int -> Int -> IO LocalPool
newLocalPool :: Int -> Int -> IO LocalPool
newLocalPool = IO TimeSpec -> Int -> Int -> IO LocalPool
newLocalPoolWithClock (Clock -> IO TimeSpec
getTime Clock
Monotonic)

-- | Supply the monotonic clock for deterministic expiry checks.
newLocalPoolWithClock :: IO TimeSpec -> Int -> Int -> IO LocalPool
newLocalPoolWithClock :: IO TimeSpec -> Int -> Int -> IO LocalPool
newLocalPoolWithClock IO TimeSpec
now Int
entries Int
bytes =
    Int
-> Int
-> TVar CacheOccupancy
-> TVar [StoreMaintenance]
-> MVar ()
-> IO TimeSpec
-> LocalPool
LocalPool (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
entries) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
bytes)
        (TVar CacheOccupancy
 -> TVar [StoreMaintenance] -> MVar () -> IO TimeSpec -> LocalPool)
-> IO (TVar CacheOccupancy)
-> IO
     (TVar [StoreMaintenance] -> MVar () -> IO TimeSpec -> LocalPool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CacheOccupancy -> IO (TVar CacheOccupancy)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (Int -> Int -> CacheOccupancy
CacheOccupancy Int
0 Int
0)
        IO (TVar [StoreMaintenance] -> MVar () -> IO TimeSpec -> LocalPool)
-> IO (TVar [StoreMaintenance])
-> IO (MVar () -> IO TimeSpec -> LocalPool)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [StoreMaintenance] -> IO (TVar [StoreMaintenance])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
        IO (MVar () -> IO TimeSpec -> LocalPool)
-> IO (MVar ()) -> IO (IO TimeSpec -> LocalPool)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> IO (MVar ())
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ()
        IO (IO TimeSpec -> LocalPool) -> IO (IO TimeSpec) -> IO LocalPool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO TimeSpec -> IO (IO TimeSpec)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO TimeSpec
now

-- | Register maintenance without erasing a store's key or value type.
registerStore :: LocalPool -> STM (Maybe TimeSpec) -> (TimeSpec -> STM ()) -> STM (CacheOccupancy, CacheOccupancy -> IO ()) -> IO ()
registerStore :: LocalPool
-> STM (Maybe TimeSpec)
-> (TimeSpec -> STM ())
-> STM (CacheOccupancy, CacheOccupancy -> IO ())
-> IO ()
registerStore LocalPool
pool STM (Maybe TimeSpec)
deadline TimeSpec -> STM ()
expire STM (CacheOccupancy, CacheOccupancy -> IO ())
observe =
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar [StoreMaintenance]
-> ([StoreMaintenance] -> [StoreMaintenance]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (LocalPool -> TVar [StoreMaintenance]
lpStores LocalPool
pool) (STM (Maybe TimeSpec)
-> (TimeSpec -> STM ())
-> STM (CacheOccupancy, CacheOccupancy -> IO ())
-> StoreMaintenance
StoreMaintenance STM (Maybe TimeSpec)
deadline TimeSpec -> STM ()
expire STM (CacheOccupancy, CacheOccupancy -> IO ())
observe StoreMaintenance -> [StoreMaintenance] -> [StoreMaintenance]
forall a. a -> [a] -> [a]
:))

-- | Expiry, entry changes and accounting commit together. Gauge reports keep commit order.
runPool :: LocalPool -> (TimeSpec -> STM a) -> IO a
runPool :: forall a. LocalPool -> (TimeSpec -> STM a) -> IO a
runPool LocalPool
pool TimeSpec -> STM a
action = MVar () -> (() -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar (LocalPool -> MVar ()
lpLock LocalPool
pool) ((() -> IO a) -> IO a) -> (() -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \() -> IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    now <- LocalPool -> IO TimeSpec
lpNow LocalPool
pool
    (result, reports) <- atomically $ do
        stores <- readTVar (lpStores pool)
        before <- traverse smObserve stores
        traverse_ (`smExpire` now) stores
        result <- action now
        after <- traverse smObserve stores
        let reports = ((CacheOccupancy, CacheOccupancy -> IO ())
 -> (CacheOccupancy, CacheOccupancy -> IO ()) -> IO ())
-> [(CacheOccupancy, CacheOccupancy -> IO ())]
-> [(CacheOccupancy, CacheOccupancy -> IO ())]
-> [IO ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (CacheOccupancy, CacheOccupancy -> IO ())
-> (CacheOccupancy, CacheOccupancy -> IO ()) -> IO ()
forall {f :: * -> *} {t} {b}.
(Applicative f, Eq t) =>
(t, b) -> (t, t -> f ()) -> f ()
report [(CacheOccupancy, CacheOccupancy -> IO ())]
before [(CacheOccupancy, CacheOccupancy -> IO ())]
after
        pure (result, reports)
    sequence_ reports
    pure result
  where
    report :: (t, b) -> (t, t -> f ()) -> f ()
report (t
before, b
_) (t
after, t -> f ()
record) = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (t
before t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/= t
after) (t -> f ()
record t
after)

-- | Reads bypass telemetry when no expiry is due. Actions must not change occupancy.
readPool :: LocalPool -> (TimeSpec -> STM a) -> IO a
readPool :: forall a. LocalPool -> (TimeSpec -> STM a) -> IO a
readPool LocalPool
pool TimeSpec -> STM a
action = do
    now <- LocalPool -> IO TimeSpec
lpNow LocalPool
pool
    fresh <- atomically $ do
        stores <- readTVar (lpStores pool)
        deadlines <- traverse smDeadline stores
        if any (maybe False (< now)) deadlines
            then pure Nothing
            else Just <$> action now
    maybe (runPool pool action) pure fresh

-- | Test aggregate capacity for one additional entry without overflowing byte arithmetic.
poolFits :: LocalPool -> Int -> STM Bool
poolFits :: LocalPool -> Int -> STM Bool
poolFits LocalPool
pool Int
weight = do
    occupancy <- TVar CacheOccupancy -> STM CacheOccupancy
forall a. TVar a -> STM a
readTVar (LocalPool -> TVar CacheOccupancy
lpOccupancy LocalPool
pool)
    pure (occEntries occupancy < lpMaxEntries pool && occBytes occupancy <= lpMaxBytes pool - weight)

-- | Apply the same committed delta as a store's own occupancy.
adjustPool :: LocalPool -> Int -> Int -> STM ()
adjustPool :: LocalPool -> Int -> Int -> STM ()
adjustPool LocalPool
pool Int
entries Int
bytes = TVar CacheOccupancy -> (CacheOccupancy -> CacheOccupancy) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (LocalPool -> TVar CacheOccupancy
lpOccupancy LocalPool
pool) ((CacheOccupancy -> CacheOccupancy) -> STM ())
-> (CacheOccupancy -> CacheOccupancy) -> STM ()
forall a b. (a -> b) -> a -> b
$ \CacheOccupancy
occupancy ->
    Int -> Int -> CacheOccupancy
CacheOccupancy (CacheOccupancy -> Int
occEntries CacheOccupancy
occupancy Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
entries) (CacheOccupancy -> Int
occBytes CacheOccupancy
occupancy Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bytes)

-- | Zero aggregate capacity disables weighing and retention.
poolEnabled :: LocalPool -> Bool
poolEnabled :: LocalPool -> Bool
poolEnabled LocalPool
pool = LocalPool -> Int
lpMaxEntries LocalPool
pool Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& LocalPool -> Int
lpMaxBytes LocalPool
pool Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

-- | Reject invalid and unretainable weights before mutating a store.
poolAcceptsWeight :: LocalPool -> Int -> Bool
poolAcceptsWeight :: LocalPool -> Int -> Bool
poolAcceptsWeight LocalPool
pool Int
weight = Int
weight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
weight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
forall a. Bounded a => a
maxBound Bool -> Bool -> Bool
&& Int
weight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= LocalPool -> Int
lpMaxBytes LocalPool
pool