{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Storage.LedgerDB.V1.Lock
  ( -- * LedgerDB lock
    LedgerDBLock
  , ReadLocked
  , WriteLocked
  , mkLedgerDBLock
  , readLocked
  , unsafeIgnoreWriteLock
  , withReadLock
  , withWriteLock
  , writeLocked
  ) where

import qualified Control.RAWLock as Lock
import NoThunks.Class
import Ouroboros.Consensus.Util.IOLike

{-------------------------------------------------------------------------------
  LedgerDB lock
-------------------------------------------------------------------------------}

-- | A lock to prevent the LedgerDB (i.e. a 'DbChangelog') from getting out of
-- sync with the 'BackingStore'.
--
-- We rely on the capability of the @BackingStore@s of providing
-- 'BackingStoreValueHandles' that can be used to hold a persistent view of the
-- database as long as the handle is open. Assuming this functionality, the lock
-- is used in three ways:
--
-- - Read lock to acquire a value handle: we do this when acquiring a view of the
--   'LedgerDB' (which lives in a 'StrictTVar' at the 'ChainDB' level) and of
--   the 'BackingStore'. We momentarily acquire a read lock, consult the
--   transactional variable and also open a 'BackingStoreValueHandle'. This is
--   the case for ledger state queries and for the forging loop.
--
-- - Read lock to ensure two operations are in sync: in the above situation, we
--   relied on the 'BackingStoreValueHandle' functionality, but sometimes we
--   won't access the values through a value handle, and instead we might use
--   the LMDB environment (as it is the case for 'lmdbCopy'). In these cases, we
--   acquire a read lock until we ended the copy, so that writers are blocked
--   until this process is completed. This is the case when taking a snapshot.
--
-- - Write lock when flushing differences.
newtype LedgerDBLock m = LedgerDBLock (Lock.RAWLock m ())

deriving newtype instance NoThunks (Lock.RAWLock m ()) => NoThunks (LedgerDBLock m)

mkLedgerDBLock :: IOLike m => m (LedgerDBLock m)
mkLedgerDBLock :: forall (m :: * -> *). IOLike m => m (LedgerDBLock m)
mkLedgerDBLock = RAWLock m () -> LedgerDBLock m
forall (m :: * -> *). RAWLock m () -> LedgerDBLock m
LedgerDBLock (RAWLock m () -> LedgerDBLock m)
-> m (RAWLock m ()) -> m (LedgerDBLock m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> m (RAWLock m ())
forall (m :: * -> *) st.
(MonadMVar m, MonadLabelledSTM m) =>
st -> m (RAWLock m st)
Lock.new ()

-- | An action in @m@ that has to hold the read lock. See @withReadLock@.
newtype ReadLocked m a = ReadLocked {forall (m :: * -> *) a. ReadLocked m a -> m a
runReadLocked :: m a}
  deriving newtype ((forall a b. (a -> b) -> ReadLocked m a -> ReadLocked m b)
-> (forall a b. a -> ReadLocked m b -> ReadLocked m a)
-> Functor (ReadLocked m)
forall a b. a -> ReadLocked m b -> ReadLocked m a
forall a b. (a -> b) -> ReadLocked m a -> ReadLocked m b
forall (m :: * -> *) a b.
Functor m =>
a -> ReadLocked m b -> ReadLocked m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ReadLocked m a -> ReadLocked m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ReadLocked m a -> ReadLocked m b
fmap :: forall a b. (a -> b) -> ReadLocked m a -> ReadLocked m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ReadLocked m b -> ReadLocked m a
<$ :: forall a b. a -> ReadLocked m b -> ReadLocked m a
Functor, Functor (ReadLocked m)
Functor (ReadLocked m) =>
(forall a. a -> ReadLocked m a)
-> (forall a b.
    ReadLocked m (a -> b) -> ReadLocked m a -> ReadLocked m b)
-> (forall a b c.
    (a -> b -> c)
    -> ReadLocked m a -> ReadLocked m b -> ReadLocked m c)
-> (forall a b. ReadLocked m a -> ReadLocked m b -> ReadLocked m b)
-> (forall a b. ReadLocked m a -> ReadLocked m b -> ReadLocked m a)
-> Applicative (ReadLocked m)
forall a. a -> ReadLocked m a
forall a b. ReadLocked m a -> ReadLocked m b -> ReadLocked m a
forall a b. ReadLocked m a -> ReadLocked m b -> ReadLocked m b
forall a b.
ReadLocked m (a -> b) -> ReadLocked m a -> ReadLocked m b
forall a b c.
(a -> b -> c) -> ReadLocked m a -> ReadLocked m b -> ReadLocked m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (ReadLocked m)
forall (m :: * -> *) a. Applicative m => a -> ReadLocked m a
forall (m :: * -> *) a b.
Applicative m =>
ReadLocked m a -> ReadLocked m b -> ReadLocked m a
forall (m :: * -> *) a b.
Applicative m =>
ReadLocked m a -> ReadLocked m b -> ReadLocked m b
forall (m :: * -> *) a b.
Applicative m =>
ReadLocked m (a -> b) -> ReadLocked m a -> ReadLocked m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ReadLocked m a -> ReadLocked m b -> ReadLocked m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> ReadLocked m a
pure :: forall a. a -> ReadLocked m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
ReadLocked m (a -> b) -> ReadLocked m a -> ReadLocked m b
<*> :: forall a b.
ReadLocked m (a -> b) -> ReadLocked m a -> ReadLocked m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ReadLocked m a -> ReadLocked m b -> ReadLocked m c
liftA2 :: forall a b c.
(a -> b -> c) -> ReadLocked m a -> ReadLocked m b -> ReadLocked m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
ReadLocked m a -> ReadLocked m b -> ReadLocked m b
*> :: forall a b. ReadLocked m a -> ReadLocked m b -> ReadLocked m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
ReadLocked m a -> ReadLocked m b -> ReadLocked m a
<* :: forall a b. ReadLocked m a -> ReadLocked m b -> ReadLocked m a
Applicative, Applicative (ReadLocked m)
Applicative (ReadLocked m) =>
(forall a b.
 ReadLocked m a -> (a -> ReadLocked m b) -> ReadLocked m b)
-> (forall a b. ReadLocked m a -> ReadLocked m b -> ReadLocked m b)
-> (forall a. a -> ReadLocked m a)
-> Monad (ReadLocked m)
forall a. a -> ReadLocked m a
forall a b. ReadLocked m a -> ReadLocked m b -> ReadLocked m b
forall a b.
ReadLocked m a -> (a -> ReadLocked m b) -> ReadLocked m b
forall (m :: * -> *). Monad m => Applicative (ReadLocked m)
forall (m :: * -> *) a. Monad m => a -> ReadLocked m a
forall (m :: * -> *) a b.
Monad m =>
ReadLocked m a -> ReadLocked m b -> ReadLocked m b
forall (m :: * -> *) a b.
Monad m =>
ReadLocked m a -> (a -> ReadLocked m b) -> ReadLocked m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ReadLocked m a -> (a -> ReadLocked m b) -> ReadLocked m b
>>= :: forall a b.
ReadLocked m a -> (a -> ReadLocked m b) -> ReadLocked m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ReadLocked m a -> ReadLocked m b -> ReadLocked m b
>> :: forall a b. ReadLocked m a -> ReadLocked m b -> ReadLocked m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> ReadLocked m a
return :: forall a. a -> ReadLocked m a
Monad)

-- | Enforce that the action has to be run while holding the read lock.
readLocked :: m a -> ReadLocked m a
readLocked :: forall (m :: * -> *) a. m a -> ReadLocked m a
readLocked = m a -> ReadLocked m a
forall (m :: * -> *) a. m a -> ReadLocked m a
ReadLocked

-- | Acquire the ledger DB read lock and hold it while performing an action
withReadLock :: IOLike m => LedgerDBLock m -> ReadLocked m a -> m a
withReadLock :: forall (m :: * -> *) a.
IOLike m =>
LedgerDBLock m -> ReadLocked m a -> m a
withReadLock (LedgerDBLock RAWLock m ()
lock) ReadLocked m a
m =
  RAWLock m () -> (() -> m a) -> m a
forall (m :: * -> *) st a.
(MonadSTM m, MonadCatch m, MonadThrow (STM m)) =>
RAWLock m st -> (st -> m a) -> m a
Lock.withReadAccess RAWLock m ()
lock (\() -> ReadLocked m a -> m a
forall (m :: * -> *) a. ReadLocked m a -> m a
runReadLocked ReadLocked m a
m)

-- | An action in @m@ that has to hold the write lock. See @withWriteLock@.
newtype WriteLocked m a = WriteLocked {forall (m :: * -> *) a. WriteLocked m a -> m a
runWriteLocked :: m a}
  deriving newtype ((forall a b. (a -> b) -> WriteLocked m a -> WriteLocked m b)
-> (forall a b. a -> WriteLocked m b -> WriteLocked m a)
-> Functor (WriteLocked m)
forall a b. a -> WriteLocked m b -> WriteLocked m a
forall a b. (a -> b) -> WriteLocked m a -> WriteLocked m b
forall (m :: * -> *) a b.
Functor m =>
a -> WriteLocked m b -> WriteLocked m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> WriteLocked m a -> WriteLocked m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> WriteLocked m a -> WriteLocked m b
fmap :: forall a b. (a -> b) -> WriteLocked m a -> WriteLocked m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> WriteLocked m b -> WriteLocked m a
<$ :: forall a b. a -> WriteLocked m b -> WriteLocked m a
Functor, Functor (WriteLocked m)
Functor (WriteLocked m) =>
(forall a. a -> WriteLocked m a)
-> (forall a b.
    WriteLocked m (a -> b) -> WriteLocked m a -> WriteLocked m b)
-> (forall a b c.
    (a -> b -> c)
    -> WriteLocked m a -> WriteLocked m b -> WriteLocked m c)
-> (forall a b.
    WriteLocked m a -> WriteLocked m b -> WriteLocked m b)
-> (forall a b.
    WriteLocked m a -> WriteLocked m b -> WriteLocked m a)
-> Applicative (WriteLocked m)
forall a. a -> WriteLocked m a
forall a b. WriteLocked m a -> WriteLocked m b -> WriteLocked m a
forall a b. WriteLocked m a -> WriteLocked m b -> WriteLocked m b
forall a b.
WriteLocked m (a -> b) -> WriteLocked m a -> WriteLocked m b
forall a b c.
(a -> b -> c)
-> WriteLocked m a -> WriteLocked m b -> WriteLocked m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (WriteLocked m)
forall (m :: * -> *) a. Applicative m => a -> WriteLocked m a
forall (m :: * -> *) a b.
Applicative m =>
WriteLocked m a -> WriteLocked m b -> WriteLocked m a
forall (m :: * -> *) a b.
Applicative m =>
WriteLocked m a -> WriteLocked m b -> WriteLocked m b
forall (m :: * -> *) a b.
Applicative m =>
WriteLocked m (a -> b) -> WriteLocked m a -> WriteLocked m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> WriteLocked m a -> WriteLocked m b -> WriteLocked m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> WriteLocked m a
pure :: forall a. a -> WriteLocked m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
WriteLocked m (a -> b) -> WriteLocked m a -> WriteLocked m b
<*> :: forall a b.
WriteLocked m (a -> b) -> WriteLocked m a -> WriteLocked m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> WriteLocked m a -> WriteLocked m b -> WriteLocked m c
liftA2 :: forall a b c.
(a -> b -> c)
-> WriteLocked m a -> WriteLocked m b -> WriteLocked m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
WriteLocked m a -> WriteLocked m b -> WriteLocked m b
*> :: forall a b. WriteLocked m a -> WriteLocked m b -> WriteLocked m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
WriteLocked m a -> WriteLocked m b -> WriteLocked m a
<* :: forall a b. WriteLocked m a -> WriteLocked m b -> WriteLocked m a
Applicative, Applicative (WriteLocked m)
Applicative (WriteLocked m) =>
(forall a b.
 WriteLocked m a -> (a -> WriteLocked m b) -> WriteLocked m b)
-> (forall a b.
    WriteLocked m a -> WriteLocked m b -> WriteLocked m b)
-> (forall a. a -> WriteLocked m a)
-> Monad (WriteLocked m)
forall a. a -> WriteLocked m a
forall a b. WriteLocked m a -> WriteLocked m b -> WriteLocked m b
forall a b.
WriteLocked m a -> (a -> WriteLocked m b) -> WriteLocked m b
forall (m :: * -> *). Monad m => Applicative (WriteLocked m)
forall (m :: * -> *) a. Monad m => a -> WriteLocked m a
forall (m :: * -> *) a b.
Monad m =>
WriteLocked m a -> WriteLocked m b -> WriteLocked m b
forall (m :: * -> *) a b.
Monad m =>
WriteLocked m a -> (a -> WriteLocked m b) -> WriteLocked m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
WriteLocked m a -> (a -> WriteLocked m b) -> WriteLocked m b
>>= :: forall a b.
WriteLocked m a -> (a -> WriteLocked m b) -> WriteLocked m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
WriteLocked m a -> WriteLocked m b -> WriteLocked m b
>> :: forall a b. WriteLocked m a -> WriteLocked m b -> WriteLocked m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> WriteLocked m a
return :: forall a. a -> WriteLocked m a
Monad)

-- | Used safely, for example, during initialization.
unsafeIgnoreWriteLock :: WriteLocked m a -> m a
unsafeIgnoreWriteLock :: forall (m :: * -> *) a. WriteLocked m a -> m a
unsafeIgnoreWriteLock = WriteLocked m a -> m a
forall (m :: * -> *) a. WriteLocked m a -> m a
runWriteLocked

-- | Enforce that the action has to be run while holding the write lock.
writeLocked :: m a -> WriteLocked m a
writeLocked :: forall (m :: * -> *) a. m a -> WriteLocked m a
writeLocked = m a -> WriteLocked m a
forall (m :: * -> *) a. m a -> WriteLocked m a
WriteLocked

-- | Acquire the ledger DB write lock and hold it while performing an action
withWriteLock :: IOLike m => LedgerDBLock m -> WriteLocked m a -> m a
withWriteLock :: forall (m :: * -> *) a.
IOLike m =>
LedgerDBLock m -> WriteLocked m a -> m a
withWriteLock (LedgerDBLock RAWLock m ()
lock) WriteLocked m a
m =
  RAWLock m () -> (() -> m (a, ())) -> m a
forall (m :: * -> *) st a.
(MonadSTM m, MonadCatch m, MonadThrow (STM m)) =>
RAWLock m st -> (st -> m (a, st)) -> m a
Lock.withWriteAccess RAWLock m ()
lock (\() -> (,()) (a -> (a, ())) -> m a -> m (a, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriteLocked m a -> m a
forall (m :: * -> *) a. WriteLocked m a -> m a
runWriteLocked WriteLocked m a
m)