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

{- | The read side of the advisory database's atomic shadow-swap: a slot holding
the currently-active 'CveDb' generation, read through a bracket so the swap can
tell when a superseded generation is no longer required for reads.

One slot serves one ecosystem's artifact. Rule evaluations borrow the current
generation's 'CveLookup' view through 'withSlotLookup' (the composition root
installs it as 'Ecluse.Core.Rules.rdWithCveLookup'); the sync task installs a
newly-verified generation with 'swapIn', which waits for the displaced
generation's readers to drain and then closes it. Closing is also the
reclamation: the sync task has already renamed the new artifact over the old
one's only file name, so the drained close releases the old inode's last
reference and the kernel frees the storage. Pruning is a property the OS
enforces, never a delete this code could mistime.

Before the first successful sync the slot is empty and hands readers
'Nothing'; the CVE rule abstains and the ordinary policy governs.
-}
module Ecluse.Core.Cve.Slot (
    CveSlot,
    newCveSlot,
    withSlotLookup,
    currentAdvisoryEtag,
    swapIn,
) where

import Control.Concurrent.STM (check)
import UnliftIO.Exception (bracket)

import Ecluse.Core.Cve (CveDb (..), CveLookup, DbEtag)

{- | One installed generation: the owning resource, its artifact ETag, and its
live-reader count.
-}
data Generation = Generation
    { Generation -> CveDb
genDb :: CveDb
    , Generation -> DbEtag
genEtag :: DbEtag
    , Generation -> TVar Int
genReaders :: TVar Int
    }

-- | The slot: the currently-active generation, or nothing before the first sync.
newtype CveSlot = CveSlot (TVar (Maybe Generation))

-- | A fresh, empty slot: readers see 'Nothing' until the first 'swapIn'.
newCveSlot :: IO CveSlot
newCveSlot :: IO CveSlot
newCveSlot = TVar (Maybe Generation) -> CveSlot
CveSlot (TVar (Maybe Generation) -> CveSlot)
-> IO (TVar (Maybe Generation)) -> IO CveSlot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Generation -> IO (TVar (Maybe Generation))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe Generation
forall a. Maybe a
Nothing

{- | Borrow the current generation's view for the duration of one action. The
generation is pinned (its reader count held above zero) for exactly the
bracket, so a concurrent 'swapIn' cannot close it mid-read; a swap landing
during the action only means the /next/ bracket sees the new generation.
-}
withSlotLookup :: CveSlot -> (Maybe CveLookup -> IO a) -> IO a
withSlotLookup :: forall a. CveSlot -> (Maybe CveLookup -> IO a) -> IO a
withSlotLookup (CveSlot TVar (Maybe Generation)
cell) Maybe CveLookup -> IO a
use = IO (Maybe Generation)
-> (Maybe Generation -> IO ())
-> (Maybe Generation -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket IO (Maybe Generation)
acquire Maybe Generation -> IO ()
release (Maybe CveLookup -> IO a
use (Maybe CveLookup -> IO a)
-> (Maybe Generation -> Maybe CveLookup)
-> Maybe Generation
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Generation -> CveLookup) -> Maybe Generation -> Maybe CveLookup
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CveDb -> CveLookup
cveDbLookup (CveDb -> CveLookup)
-> (Generation -> CveDb) -> Generation -> CveLookup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generation -> CveDb
genDb))
  where
    acquire :: IO (Maybe Generation)
acquire = STM (Maybe Generation) -> IO (Maybe Generation)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe Generation) -> IO (Maybe Generation))
-> STM (Maybe Generation) -> IO (Maybe Generation)
forall a b. (a -> b) -> a -> b
$ do
        mGen <- TVar (Maybe Generation) -> STM (Maybe Generation)
forall a. TVar a -> STM a
readTVar TVar (Maybe Generation)
cell
        for_ mGen (\Generation
g -> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Generation -> TVar Int
genReaders Generation
g) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
        pure mGen
    release :: Maybe Generation -> IO ()
release = (Generation -> IO ()) -> Maybe Generation -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Generation
g -> STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Generation -> TVar Int
genReaders Generation
g) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)))

{- | The active generation's artifact 'DbEtag', or 'Nothing' before the first
sync. A non-pinning read: it snapshots the live generation's identity without
bumping the reader count, so it never delays a swap. It answers "which advisory
database is live right now" for the audit trail, not "hold this generation
open", so a swap landing just after it read means a later reader saw the newer
database. The evaluation context resolves this once per request.
-}
currentAdvisoryEtag :: CveSlot -> IO (Maybe DbEtag)
currentAdvisoryEtag :: CveSlot -> IO (Maybe DbEtag)
currentAdvisoryEtag (CveSlot TVar (Maybe Generation)
cell) = (Generation -> DbEtag) -> Maybe Generation -> Maybe DbEtag
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Generation -> DbEtag
genEtag (Maybe Generation -> Maybe DbEtag)
-> IO (Maybe Generation) -> IO (Maybe DbEtag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe Generation) -> IO (Maybe Generation)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe Generation)
cell

{- | Install a newly-verified generation and retire the one it displaces:
publish the new 'CveDb' to readers atomically, wait for the displaced
generation's readers to drain to zero, then close it, releasing the old
artifact's last inode reference (see the module header). Blocks only the
caller (the sync task), and only for as long as the longest in-flight
evaluation, which the rule's resilience timeout already bounds.

__The slot owns the new database from the moment this is entered__:
publication is the first effect and is atomic, so no failure mode of this
call leaves the new generation both unpublished and unclosed, and no caller
cleanup may close it. A close failure on the displaced generation is
swallowed (the swap already succeeded; the stale connection is the only
casualty), while cancellation during the drain wait propagates, leaving the
new generation live and the displaced one unclosed until process exit.

Safe under a single swapper (the one sync task per slot); with several, each
call retires exactly the generation it displaced.
-}
swapIn :: CveSlot -> DbEtag -> CveDb -> IO ()
swapIn :: CveSlot -> DbEtag -> CveDb -> IO ()
swapIn (CveSlot TVar (Maybe Generation)
cell) DbEtag
etag CveDb
newDb = do
    readers <- Int -> IO (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (Int
0 :: Int)
    displaced <- atomically $ do
        old <- readTVar cell
        writeTVar cell (Just (Generation newDb etag readers))
        pure old
    for_ displaced $ \Generation
g -> do
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar (Generation -> TVar Int
genReaders Generation
g) STM Int -> (Int -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM ()
check (Bool -> STM ()) -> (Int -> Bool) -> Int -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0))
        -- 'cveDbClose' never throws (the handle absorbs close faults), so the
        -- swallow the module header describes needs no guard here.
        CveDb -> IO ()
cveDbClose (Generation -> CveDb
genDb Generation
g)