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

{- | Advisory generations stay pinned for each lookup. Retirement belongs to the last
reader, or to the swapper when no readers remain, even if the swapper is cancelled.
-}
module Ecluse.Core.Cve.Slot (
    CveSlot,
    newCveSlot,
    withSlotGeneration,
    currentAdvisoryEtag,
    AdvisorySource (..),
    currentAdvisorySource,
    observeAdvisoryPublication,
    generationInstalledAt,
    swapIn,
) where

import Data.Time (UTCTime)
import GHC.Clock (getMonotonicTime)
import UnliftIO.Exception (bracket, mask_, uninterruptibleMask_)

import Ecluse.Core.Cve (CveDb (..), CveLookup)
import Ecluse.Core.Cve.Types (DbEtag)
import Ecluse.Core.Osv.Provenance (AdvisoryProvenance)

data Generation = Generation
    { Generation -> CveDb
genDb :: CveDb
    , Generation -> DbEtag
genEtag :: DbEtag
    , Generation -> AdvisorySource
genSource :: AdvisorySource
    , Generation -> TVar Bool
genRetired :: TVar Bool
    , Generation -> TMVar ()
genClosed :: TMVar ()
    , Generation -> TVar Int
genReaders :: TVar Int
    , Generation -> Double
genInstalledAt :: Double
    }

{- | Where the serving artifact came from. The publication time is the store's, not the
artifact's, so republishing the same bytes can advance it.
-}
data AdvisorySource = AdvisorySource
    { AdvisorySource -> AdvisoryProvenance
asProvenance :: AdvisoryProvenance
    , AdvisorySource -> Maybe UTCTime
asPushedAt :: Maybe UTCTime
    -- ^ The published object's own timestamp, 'Nothing' when the store reported none.
    }
    deriving stock (AdvisorySource -> AdvisorySource -> Bool
(AdvisorySource -> AdvisorySource -> Bool)
-> (AdvisorySource -> AdvisorySource -> Bool) -> Eq AdvisorySource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AdvisorySource -> AdvisorySource -> Bool
== :: AdvisorySource -> AdvisorySource -> Bool
$c/= :: AdvisorySource -> AdvisorySource -> Bool
/= :: AdvisorySource -> AdvisorySource -> Bool
Eq, Int -> AdvisorySource -> ShowS
[AdvisorySource] -> ShowS
AdvisorySource -> String
(Int -> AdvisorySource -> ShowS)
-> (AdvisorySource -> String)
-> ([AdvisorySource] -> ShowS)
-> Show AdvisorySource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AdvisorySource -> ShowS
showsPrec :: Int -> AdvisorySource -> ShowS
$cshow :: AdvisorySource -> String
show :: AdvisorySource -> String
$cshowList :: [AdvisorySource] -> ShowS
showList :: [AdvisorySource] -> ShowS
Show)

-- | The slot: the currently-active generation, or nothing before the first sync.
newtype CveSlot = CveSlot {CveSlot -> TVar (Maybe Generation)
slotCell :: 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 a lookup and its own ETag together until the action returns or is cancelled.
withSlotGeneration :: CveSlot -> (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
withSlotGeneration :: forall a. CveSlot -> (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
withSlotGeneration CveSlot
slot Maybe (DbEtag, 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 (DbEtag, CveLookup) -> IO a
use (Maybe (DbEtag, CveLookup) -> IO a)
-> (Maybe Generation -> Maybe (DbEtag, CveLookup))
-> Maybe Generation
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Generation -> (DbEtag, CveLookup))
-> Maybe Generation -> Maybe (DbEtag, CveLookup)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Generation
g -> (Generation -> DbEtag
genEtag Generation
g, CveDb -> CveLookup
cveDbLookup (Generation -> CveDb
genDb Generation
g))))
  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 (CveSlot -> TVar (Maybe Generation)
slotCell CveSlot
slot)
        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 -> IO ()) -> Maybe Generation -> IO ())
-> (Generation -> IO ()) -> Maybe Generation -> IO ()
forall a b. (a -> b) -> a -> b
$ \Generation
g -> do
        shouldClose <- STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
            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)
            remaining <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar (Generation -> TVar Int
genReaders Generation
g)
            retired <- readTVar (genRetired g)
            pure (retired && remaining == 0)
        when shouldClose (closeGeneration g)

{- | The active generation's artifact 'DbEtag', or 'Nothing' before the first sync. The
read does not pin the generation, so it never delays a 'swapIn'.
-}
currentAdvisoryEtag :: CveSlot -> IO (Maybe DbEtag)
currentAdvisoryEtag :: CveSlot -> IO (Maybe DbEtag)
currentAdvisoryEtag CveSlot
slot = (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 (CveSlot -> TVar (Maybe Generation)
slotCell CveSlot
slot)

{- | What the serving artifact came from, or 'Nothing' before the first sync. A failed poll
never reaches 'swapIn', so a warm process keeps the last value it read.
-}
currentAdvisorySource :: CveSlot -> IO (Maybe AdvisorySource)
currentAdvisorySource :: CveSlot -> IO (Maybe AdvisorySource)
currentAdvisorySource CveSlot
slot = (Generation -> AdvisorySource)
-> Maybe Generation -> Maybe AdvisorySource
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Generation -> AdvisorySource
genSource (Maybe Generation -> Maybe AdvisorySource)
-> IO (Maybe Generation) -> IO (Maybe AdvisorySource)
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 (CveSlot -> TVar (Maybe Generation)
slotCell CveSlot
slot)

-- | Advance publication time only for the installed ETag, without replacing or retiring its database.
observeAdvisoryPublication :: CveSlot -> DbEtag -> Maybe UTCTime -> IO ()
observeAdvisoryPublication :: CveSlot -> DbEtag -> Maybe UTCTime -> IO ()
observeAdvisoryPublication CveSlot
slot DbEtag
etag Maybe UTCTime
pushedAt = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    current <- TVar (Maybe Generation) -> STM (Maybe Generation)
forall a. TVar a -> STM a
readTVar (CveSlot -> TVar (Maybe Generation)
slotCell CveSlot
slot)
    for_ current $ \Generation
g ->
        Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Generation -> DbEtag
genEtag Generation
g DbEtag -> DbEtag -> Bool
forall a. Eq a => a -> a -> Bool
== DbEtag
etag Bool -> Bool -> Bool
&& Maybe UTCTime
pushedAt Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> AdvisorySource -> Maybe UTCTime
asPushedAt (Generation -> AdvisorySource
genSource Generation
g)) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
            TVar (Maybe Generation) -> Maybe Generation -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (CveSlot -> TVar (Maybe Generation)
slotCell CveSlot
slot) (Generation -> Maybe Generation
forall a. a -> Maybe a
Just Generation
g{genSource = (genSource g){asPushedAt = pushedAt}})

{- | When the serving generation went live, or 'Nothing' while no swap has landed. Only 'swapIn'
moves it, so it measures what the slot serves, not the liveness of what fills it.
-}
generationInstalledAt :: CveSlot -> IO (Maybe Double)
generationInstalledAt :: CveSlot -> IO (Maybe Double)
generationInstalledAt CveSlot
slot = (Generation -> Double) -> Maybe Generation -> Maybe Double
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Generation -> Double
genInstalledAt (Maybe Generation -> Maybe Double)
-> IO (Maybe Generation) -> IO (Maybe Double)
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 (CveSlot -> TVar (Maybe Generation)
slotCell CveSlot
slot)

{- | Install a newly verified generation, drain the displaced one's readers, then close it.
The slot owns @newDb@ from entry, so no caller cleanup may close it.
-}
swapIn :: CveSlot -> DbEtag -> Maybe UTCTime -> CveDb -> IO ()
swapIn :: CveSlot -> DbEtag -> Maybe UTCTime -> CveDb -> IO ()
swapIn CveSlot
slot DbEtag
etag Maybe UTCTime
pushedAt CveDb
newDb = IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    readers <- Int -> IO (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (Int
0 :: Int)
    retired <- newTVarIO False
    closed <- newEmptyTMVarIO
    installedAt <- getMonotonicTime
    let source = AdvisorySource{asProvenance :: AdvisoryProvenance
asProvenance = CveDb -> AdvisoryProvenance
cveDbProvenance CveDb
newDb, asPushedAt :: Maybe UTCTime
asPushedAt = Maybe UTCTime
pushedAt}
    displaced <- atomically $ do
        old <- readTVar (slotCell slot)
        writeTVar (slotCell slot) (Just (Generation newDb etag source retired closed readers installedAt))
        forM old $ \Generation
g -> do
            TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Generation -> TVar Bool
genRetired Generation
g) Bool
True
            remaining <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar (Generation -> TVar Int
genReaders Generation
g)
            pure (g, remaining == 0)
    for_ displaced $ \(Generation
g, Bool
shouldClose) -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldClose (Generation -> IO ()
closeGeneration Generation
g)
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar () -> STM ()
forall a. TMVar a -> STM a
readTMVar (Generation -> TMVar ()
genClosed Generation
g))

-- The close contract never throws. Protect only close and completion, never the reader drain.
closeGeneration :: Generation -> IO ()
closeGeneration :: Generation -> IO ()
closeGeneration Generation
g = IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    CveDb -> IO ()
cveDbClose (Generation -> CveDb
genDb Generation
g)
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (Generation -> TMVar ()
genClosed Generation
g) ())