{- | 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,
    swapIn,
) where

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

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

-- | One installed generation: the owning resource and its live-reader count.
data Generation = Generation
    { Generation -> CveDb
genDb :: CveDb
    , 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)))

{- | 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 -> CveDb -> IO ()
swapIn :: CveSlot -> CveDb -> IO ()
swapIn (CveSlot TVar (Maybe Generation)
cell) 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 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))
        CveDb -> IO ()
cveDbClose (Generation -> CveDb
genDb Generation
g) IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass