{-# OPTIONS_GHC -Wno-redundant-constraints#-}
-- We intentionally specify more constraints than necessary for some exports.
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-|
Copyright   : © 2022-2023 IOHK, 2023-2025 Cardano Foundation
License     : Apache-2.0
Description : Mutable variable that mirrors its value in a 'Data.Store.Store'.

'DBVar' represents a mutable variable that stores one Haskell value
in volatile memory (RAM),
but mirrors the value to persistent storage,
for example to a database on disk.

* 'Store' represents the storage facility to which the variable is mirrored.
* Read-access is from volatile memory and highly concurrent.
* Updates are incremental and use delta types, see "Data.Delta".
-}
module Data.DBVar (
      DBVar
    , readDBVar
    , updateDBVar
    , modifyDBVar
    , modifyDBMaybe
    , initDBVar
    , loadDBVar
    ) where

import Prelude

import Control.Concurrent.Class.MonadSTM
    ( MonadSTM
    , atomically
    , newTVarIO
    , readTVar
    , readTVarIO
    , retry
    , writeTVar
    )
import Control.Monad.Class.MonadThrow
    ( MonadEvaluate
    , MonadMask
    , MonadThrow
    , bracket
    , evaluate
    , mask
    , throwIO
    )
import Data.Delta
    ( Delta (..)
    )
import Data.Store
    ( Store (..)
    , UpdateStore
    )

{-------------------------------------------------------------------------------
    DBVar
-------------------------------------------------------------------------------}
-- | A 'DBVar'@ m delta@ is a mutable reference to a Haskell value of type @a@.
-- The type @delta@ is a delta type for this value type @a@,
-- that is we have @a ~ @'Base'@ delta@.
--
-- The Haskell value is cached in memory, in weak head normal form (WHNF).
-- However, whenever the value is updated, a copy of the value will be written
-- to persistent storage like a file or database on disk;
-- the specific storage facility is represented by a 'Store'.
-- For efficient updates, the delta type @delta@ is used in the update.
--
-- Concurrency: 'DBVar' fully supports concurrent reads and updates.
--
-- * Updates are atomic and will block other updates.
-- * Reads will /not/ be blocked during an update
--   (except for a small moment where the new value atomically
--    replaces the old one).
data DBVar m delta = DBVar
    { forall (m :: * -> *) delta. DBVar m delta -> m (Base delta)
readDBVar_     :: m (Base delta)
    , forall (m :: * -> *) delta.
DBVar m delta -> forall b. (Base delta -> (Maybe delta, b)) -> m b
modifyDBMaybe_ :: forall b. (Base delta -> (Maybe delta, b)) -> m b
    }

-- | Read the current value of the 'DBVar'.
readDBVar :: (Delta da, a ~ Base da) => DBVar m da -> m a
readDBVar :: forall da a (m :: * -> *).
(Delta da, a ~ Base da) =>
DBVar m da -> m a
readDBVar = DBVar m da -> m a
DBVar m da -> m (Base da)
forall (m :: * -> *) delta. DBVar m delta -> m (Base delta)
readDBVar_

-- | Update the value of the 'DBVar' using a delta type.
--
-- The new value will be evaluated to weak head normal form.
updateDBVar :: (Delta da, Monad m) => DBVar m da -> da -> m ()
updateDBVar :: forall da (m :: * -> *).
(Delta da, Monad m) =>
DBVar m da -> da -> m ()
updateDBVar DBVar m da
var da
delta = DBVar m da -> forall b. (Base da -> (Maybe da, b)) -> m b
forall da (m :: * -> *) a.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> forall b. (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar m da
var ((Base da -> (Maybe da, ())) -> m ())
-> (Base da -> (Maybe da, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \Base da
_ -> (da -> Maybe da
forall a. a -> Maybe a
Just da
delta,())

-- | Modify the value in a 'DBVar'.
--
-- The new value will be evaluated to weak head normal form (WHNF).
modifyDBVar
    :: (Delta da, Monad m, a ~ Base da)
    => DBVar m da -> (a -> (da, b)) -> m b
modifyDBVar :: forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (da, b)) -> m b
modifyDBVar DBVar m da
var a -> (da, b)
f = DBVar m da -> forall b. (a -> (Maybe da, b)) -> m b
forall da (m :: * -> *) a.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> forall b. (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar m da
var ((a -> (Maybe da, b)) -> m b) -> (a -> (Maybe da, b)) -> m b
forall a b. (a -> b) -> a -> b
$ \a
a -> let (da
da,b
b) = a -> (da, b)
f a
a in (da -> Maybe da
forall a. a -> Maybe a
Just da
da,b
b)

-- | Maybe modify the value in a 'DBVar'
--
-- If updated,
-- the new value will be evaluated to weak head normal form (WHNF).
modifyDBMaybe
    :: (Delta da, Monad m, a ~ Base da)
    => DBVar m da -> forall b. (a -> (Maybe da, b)) -> m b
modifyDBMaybe :: forall da (m :: * -> *) a.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> forall b. (a -> (Maybe da, b)) -> m b
modifyDBMaybe = DBVar m da -> (a -> (Maybe da, b)) -> m b
DBVar m da -> forall b. (Base da -> (Maybe da, b)) -> m b
forall (m :: * -> *) delta.
DBVar m delta -> forall b. (Base delta -> (Maybe delta, b)) -> m b
modifyDBMaybe_

-- | Initialize a new 'DBVar' that mirrors to a given 'Store'.
initDBVar
    ::  ( MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m
        , Delta da, a ~ Base da
        )
    => UpdateStore m da -- ^ 'Store' for mirroring.
    -> a -- ^ Initial value.
    -> m (DBVar m da)
initDBVar :: forall (m :: * -> *) da a.
(MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m, Delta da,
 a ~ Base da) =>
UpdateStore m da -> a -> m (DBVar m da)
initDBVar UpdateStore m da
store a
v = do
    Store m (Whole a) da -> Base da -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS Store m (Whole a) da
UpdateStore m da
store a
Base da
v
    (a -> da -> m ()) -> a -> m (DBVar m da)
forall (m :: * -> *) da a.
(MonadSTM m, MonadThrow m, MonadMask m, MonadEvaluate m, Delta da,
 a ~ Base da) =>
(a -> da -> m ()) -> a -> m (DBVar m da)
newWithCache (Store m (Whole a) da -> Maybe (Base da) -> da -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS Store m (Whole a) da
UpdateStore m da
store (Maybe a -> da -> m ()) -> (a -> Maybe a) -> a -> da -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just) a
v

-- | Create a 'DBVar' that mirrors to a given 'Store',
-- and also loads its initial value from there.
-- Throws an exception if the value cannot be loaded.
loadDBVar
    ::  ( MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m
        , Delta da
        )
    => UpdateStore m da -- ^ 'Store' for mirroring and for reading the initial value.
    -> m (DBVar m da)
loadDBVar :: forall (m :: * -> *) da.
(MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m,
 Delta da) =>
UpdateStore m da -> m (DBVar m da)
loadDBVar UpdateStore m da
store =
    UpdateStore m da -> m (Either SomeException (Base da))
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS UpdateStore m da
store m (Either SomeException (Base da))
-> (Either SomeException (Base da) -> m (DBVar m da))
-> m (DBVar m da)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left  SomeException
e -> SomeException -> m (DBVar m da)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
        Right Base da
a -> (Base da -> da -> m ()) -> Base da -> m (DBVar m da)
forall (m :: * -> *) da a.
(MonadSTM m, MonadThrow m, MonadMask m, MonadEvaluate m, Delta da,
 a ~ Base da) =>
(a -> da -> m ()) -> a -> m (DBVar m da)
newWithCache (UpdateStore m da -> Maybe (Base da) -> da -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS UpdateStore m da
store (Maybe (Base da) -> da -> m ())
-> (Base da -> Maybe (Base da)) -> Base da -> da -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base da -> Maybe (Base da)
forall a. a -> Maybe a
Just) Base da
a

-- | Create 'DBVar' from an initial value and an update function
-- using a 'TVar' as in-memory cache.
--
-- Space: The value in the 'TVar' will be evaluated to weak head normal form.
--
-- Concurrency: The update function needs to be atomic even in the presence
-- of asynchronous exceptions.
newWithCache
    ::  ( MonadSTM m, MonadThrow m, MonadMask m, MonadEvaluate m
        , Delta da, a ~ Base da
        )
    => (a -> da -> m ()) -> a -> m (DBVar m da)
newWithCache :: forall (m :: * -> *) da a.
(MonadSTM m, MonadThrow m, MonadMask m, MonadEvaluate m, Delta da,
 a ~ Base da) =>
(a -> da -> m ()) -> a -> m (DBVar m da)
newWithCache a -> da -> m ()
update a
a = do
    TVar m a
cache  <- a -> m (TVar m a)
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO a
a
    TVar m Bool
locked <- Bool -> m (TVar m Bool)
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Bool
False   -- lock for updating the cache
    DBVar m da -> m (DBVar m da)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DBVar m da -> m (DBVar m da)) -> DBVar m da -> m (DBVar m da)
forall a b. (a -> b) -> a -> b
$ DBVar
        { readDBVar_ :: m (Base da)
readDBVar_     = TVar m a -> m a
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m a
cache
        , modifyDBMaybe_ :: forall b. (Base da -> (Maybe da, b)) -> m b
modifyDBMaybe_ = \Base da -> (Maybe da, b)
f -> do
            let before :: m a
before = STM m a -> m a
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m a -> m a) -> STM m a -> m a
forall a b. (a -> b) -> a -> b
$ do
                    TVar m Bool -> STM m Bool
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Bool
locked STM m Bool -> (Bool -> STM m a) -> STM m a
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Bool
True  -> STM m a
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                        Bool
False -> do
                            TVar m Bool -> Bool -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
locked Bool
True
                            TVar m a -> STM m a
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m a
cache
                after :: a -> m ()
after a
_ = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m Bool -> Bool -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
locked Bool
False
                action :: a -> m b
action a
old = do
                    let (Maybe da
mdelta, b
b) = Base da -> (Maybe da, b)
f a
Base da
old
                    case Maybe da
mdelta of
                        Maybe da
Nothing    -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        Just da
delta -> do
                            a
new <- a -> m a
forall a. a -> m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ da -> Base da -> Base da
forall delta. Delta delta => delta -> Base delta -> Base delta
apply da
delta a
Base da
old
                            ((forall a. m a -> m a) -> m ()) -> m ()
forall b. ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m ()) -> m ())
-> ((forall a. m a -> m a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
                                -- We mask asynchronous exceptions here
                                -- to ensure that the TVar will be updated
                                -- whenever @update@ succeeds without exception.
                                m () -> m ()
forall a. m a -> m a
restore (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ a -> da -> m ()
update a
old da
delta
                                STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m a -> a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m a
cache a
new
                    b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
            m a -> (a -> m ()) -> (a -> m b) -> m b
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m a
before a -> m ()
after a -> m b
action
        }