{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}

-- | LMDB resource status with read-append-write locking
module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB.Status
  ( -- * Status
    Status (..)
  , StatusLock

    -- * Locks
  , new
  , withReadAccess
  , withWriteAccess
  ) where

import Control.RAWLock (RAWLock)
import qualified Control.RAWLock as RAW
import Data.Functor ((<&>))
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Util.IOLike (IOLike)

{-------------------------------------------------------------------------------
  Status
-------------------------------------------------------------------------------}

-- | A 'RAWLock' for 'Status'.
newtype StatusLock m = StatusLock {forall (m :: * -> *). StatusLock m -> RAWLock m Status
getStatusLock :: RAWLock m Status}

-- | Whether a resource is open or closed.
--
-- Resources that we keep track of are: (i) the full LMDB backing store, and
-- (ii) each of the LMDB backing store value handles.
data Status = Open | Closed
  deriving stock (Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Status -> ShowS
showsPrec :: Int -> Status -> ShowS
$cshow :: Status -> String
show :: Status -> String
$cshowList :: [Status] -> ShowS
showList :: [Status] -> ShowS
Show, Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
/= :: Status -> Status -> Bool
Eq, (forall x. Status -> Rep Status x)
-> (forall x. Rep Status x -> Status) -> Generic Status
forall x. Rep Status x -> Status
forall x. Status -> Rep Status x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Status -> Rep Status x
from :: forall x. Status -> Rep Status x
$cto :: forall x. Rep Status x -> Status
to :: forall x. Rep Status x -> Status
Generic)
  deriving anyclass Context -> Status -> IO (Maybe ThunkInfo)
Proxy Status -> String
(Context -> Status -> IO (Maybe ThunkInfo))
-> (Context -> Status -> IO (Maybe ThunkInfo))
-> (Proxy Status -> String)
-> NoThunks Status
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Status -> IO (Maybe ThunkInfo)
noThunks :: Context -> Status -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Status -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Status -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Status -> String
showTypeOf :: Proxy Status -> String
NoThunks

{-------------------------------------------------------------------------------
  Locks
-------------------------------------------------------------------------------}

-- | Create a new 'StatusLock'.
new :: IOLike m => Status -> m (StatusLock m)
new :: forall (m :: * -> *). IOLike m => Status -> m (StatusLock m)
new Status
st = RAWLock m Status -> StatusLock m
forall (m :: * -> *). RAWLock m Status -> StatusLock m
StatusLock (RAWLock m Status -> StatusLock m)
-> m (RAWLock m Status) -> m (StatusLock m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Status -> m (RAWLock m Status)
forall (m :: * -> *) st.
(MonadMVar m, MonadLabelledSTM m) =>
st -> m (RAWLock m st)
RAW.new Status
st

-- | A variant of 'RAW.withWriteAccess' that throws an exception if @'Status' ==
-- 'Closed'@.
--
-- Note: contrary to 'RAW.withWriteAccess', the action to perform with the
-- acquired lock is not of type @'Status' -> ('Status', a)@. The 'Status' is
-- known to be 'Open', or an exception would have been thrown.
withWriteAccess ::
  IOLike m =>
  StatusLock m ->
  -- | Action to perform if closed
  m a ->
  -- | Action to perform if open, possibly updating the 'Status'
  m (a, Status) ->
  m a
withWriteAccess :: forall (m :: * -> *) a.
IOLike m =>
StatusLock m -> m a -> m (a, Status) -> m a
withWriteAccess StatusLock m
lock m a
ifClosed m (a, Status)
ifOpen =
  RAWLock m Status -> (Status -> m (a, Status)) -> m a
forall (m :: * -> *) st a.
(MonadSTM m, MonadCatch m, MonadThrow (STM m)) =>
RAWLock m st -> (st -> m (a, st)) -> m a
RAW.withWriteAccess (StatusLock m -> RAWLock m Status
forall (m :: * -> *). StatusLock m -> RAWLock m Status
getStatusLock StatusLock m
lock) ((Status -> m (a, Status)) -> m a)
-> (Status -> m (a, Status)) -> m a
forall a b. (a -> b) -> a -> b
$ \case
    Status
Open -> m (a, Status)
ifOpen
    Status
Closed -> m a
ifClosed m a -> (a -> (a, Status)) -> m (a, Status)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (,Status
Closed)

-- | A variant of 'RAW.withReadAccess' that throws an exception if @'Status' ==
-- 'Closed'@.
--
-- Note: contrary to 'RAW.withReadAccess', the action to perform with the
-- acquired lock is not of type @'Status' -> a@. The 'Status' is known to be
-- 'Open', or an exception would have been thrown.
withReadAccess ::
  IOLike m =>
  StatusLock m ->
  -- | Action to perform when closed
  m a ->
  -- | Action to perform when open
  m a ->
  m a
withReadAccess :: forall (m :: * -> *) a.
IOLike m =>
StatusLock m -> m a -> m a -> m a
withReadAccess StatusLock m
lock m a
ifClosed m a
ifOpen =
  RAWLock m Status -> (Status -> m a) -> m a
forall (m :: * -> *) st a.
(MonadSTM m, MonadCatch m, MonadThrow (STM m)) =>
RAWLock m st -> (st -> m a) -> m a
RAW.withReadAccess (StatusLock m -> RAWLock m Status
forall (m :: * -> *). StatusLock m -> RAWLock m Status
getStatusLock StatusLock m
lock) ((Status -> m a) -> m a) -> (Status -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \case
    Status
Open -> m a
ifOpen
    Status
Closed -> m a
ifClosed