{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Storage.LedgerDB.V2.Forker
  ( ForkerEnv (..)
  , implForkerCommit
  , implForkerGetLedgerState
  , implForkerPush
  , implForkerRangeReadTables
  , implForkerReadStatistics
  , implForkerReadTables

    -- * The API
  , module Ouroboros.Consensus.Storage.LedgerDB.Forker
  ) where

import Control.Exception
import Control.Monad (when)
import Control.RAWLock (RAWLock, withWriteAccess)
import Control.Tracer
import Data.Functor.Contravariant ((>$<))
import Data.Maybe (fromMaybe)
import GHC.Generics
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.Args
import Ouroboros.Consensus.Storage.LedgerDB.Forker
import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
import Ouroboros.Consensus.Util (whenJust)
import Ouroboros.Consensus.Util.CallStack
import Ouroboros.Consensus.Util.Enclose
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.NormalForm.StrictTVar ()
import qualified Ouroboros.Network.AnchoredSeq as AS
import Prelude hiding (read)

-- | The state inside a forker.
data ForkerEnv m l blk = ForkerEnv
  { forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
foeLedgerSeq :: !(StrictTVar m (LedgerSeq m l blk))
  -- ^ Local version of the LedgerSeq
  , forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
foeSwitchVar :: !(StrictTVar m (LedgerSeq m l blk))
  -- ^ This TVar is the same as the LedgerDB one
  , forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer :: !(Tracer m TraceForkerEvent)
  -- ^ Config
  , forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> RAWLock m ()
foeLedgerDbLock :: !(RAWLock m ())
  -- ^ 'ldbOpenHandlesLock'.
  , forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m Bool
foeWasCommitted :: !(StrictTVar m Bool)
  }
  deriving (forall x. ForkerEnv m l blk -> Rep (ForkerEnv m l blk) x)
-> (forall x. Rep (ForkerEnv m l blk) x -> ForkerEnv m l blk)
-> Generic (ForkerEnv m l blk)
forall x. Rep (ForkerEnv m l blk) x -> ForkerEnv m l blk
forall x. ForkerEnv m l blk -> Rep (ForkerEnv m l blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk x.
Rep (ForkerEnv m l blk) x -> ForkerEnv m l blk
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk x.
ForkerEnv m l blk -> Rep (ForkerEnv m l blk) x
$cfrom :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk x.
ForkerEnv m l blk -> Rep (ForkerEnv m l blk) x
from :: forall x. ForkerEnv m l blk -> Rep (ForkerEnv m l blk) x
$cto :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk x.
Rep (ForkerEnv m l blk) x -> ForkerEnv m l blk
to :: forall x. Rep (ForkerEnv m l blk) x -> ForkerEnv m l blk
Generic

deriving instance
  ( IOLike m
  , NoThunks (l blk EmptyMK)
  , NoThunks (TxIn blk)
  , NoThunks (TxOut blk)
  ) =>
  NoThunks (ForkerEnv m l blk)

{-------------------------------------------------------------------------------
  Forker operations
-------------------------------------------------------------------------------}

implForkerReadTables ::
  (IOLike m, GetTip (l blk)) =>
  ForkerEnv m l blk ->
  LedgerTables blk KeysMK ->
  m (LedgerTables blk ValuesMK)
implForkerReadTables :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, GetTip (l blk)) =>
ForkerEnv m l blk
-> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
implForkerReadTables ForkerEnv m l blk
env LedgerTables blk KeysMK
ks =
  Tracer m EnclosingTimed
-> m (LedgerTables blk ValuesMK) -> m (LedgerTables blk ValuesMK)
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (EnclosingTimed -> TraceForkerEvent
ForkerReadTables (EnclosingTimed -> TraceForkerEvent)
-> Tracer m TraceForkerEvent -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
env) (m (LedgerTables blk ValuesMK) -> m (LedgerTables blk ValuesMK))
-> m (LedgerTables blk ValuesMK) -> m (LedgerTables blk ValuesMK)
forall a b. (a -> b) -> a -> b
$ do
    stateRef <- LedgerSeq m l blk -> StateRef m l blk
forall (l :: * -> (* -> * -> *) -> *) blk (m :: * -> *).
GetTip (l blk) =>
LedgerSeq m l blk -> StateRef m l blk
currentHandle (LedgerSeq m l blk -> StateRef m l blk)
-> m (LedgerSeq m l blk) -> m (StateRef m l blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (LedgerSeq m l blk) -> m (LedgerSeq m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
foeLedgerSeq ForkerEnv m l blk
env)
    read (tables stateRef) (state stateRef) ks

implForkerRangeReadTables ::
  (IOLike m, GetTip (l blk), HasLedgerTables l blk) =>
  QueryBatchSize ->
  ForkerEnv m l blk ->
  RangeQueryPrevious blk ->
  m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
implForkerRangeReadTables :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, GetTip (l blk), HasLedgerTables l blk) =>
QueryBatchSize
-> ForkerEnv m l blk
-> RangeQueryPrevious blk
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
implForkerRangeReadTables QueryBatchSize
qbs ForkerEnv m l blk
env RangeQueryPrevious blk
rq0 =
  Tracer m EnclosingTimed
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (EnclosingTimed -> TraceForkerEvent
ForkerRangeReadTables (EnclosingTimed -> TraceForkerEvent)
-> Tracer m TraceForkerEvent -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
env) (m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
 -> m (LedgerTables blk ValuesMK, Maybe (TxIn blk)))
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall a b. (a -> b) -> a -> b
$ do
    let n :: Int
n = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ QueryBatchSize -> Word64
defaultQueryBatchSize QueryBatchSize
qbs
    stateRef <- LedgerSeq m l blk -> StateRef m l blk
forall (l :: * -> (* -> * -> *) -> *) blk (m :: * -> *).
GetTip (l blk) =>
LedgerSeq m l blk -> StateRef m l blk
currentHandle (LedgerSeq m l blk -> StateRef m l blk)
-> m (LedgerSeq m l blk) -> m (StateRef m l blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (LedgerSeq m l blk) -> m (LedgerSeq m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
foeLedgerSeq ForkerEnv m l blk
env)
    case rq0 of
      RangeQueryPrevious blk
NoPreviousQuery -> LedgerTablesHandle m l blk
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
LedgerTablesHandle m l blk
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
readRange (StateRef m l blk -> LedgerTablesHandle m l blk
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> LedgerTablesHandle m l blk
tables StateRef m l blk
stateRef) (StateRef m l blk -> l blk EmptyMK
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> l blk EmptyMK
state StateRef m l blk
stateRef) (Maybe (TxIn blk)
forall a. Maybe a
Nothing, Int
n)
      RangeQueryPrevious blk
PreviousQueryWasFinal -> (LedgerTables blk ValuesMK, Maybe (TxIn blk))
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValuesMK (TxIn blk) (TxOut blk) -> LedgerTables blk ValuesMK
forall blk (mk :: * -> * -> *).
mk (TxIn blk) (TxOut blk) -> LedgerTables blk mk
LedgerTables ValuesMK (TxIn blk) (TxOut blk)
forall k v. (Ord k, Eq v) => ValuesMK k v
forall (mk :: * -> * -> *) k v.
(ZeroableMK mk, Ord k, Eq v) =>
mk k v
emptyMK, Maybe (TxIn blk)
forall a. Maybe a
Nothing)
      PreviousQueryWasUpTo TxIn blk
k ->
        LedgerTablesHandle m l blk
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
LedgerTablesHandle m l blk
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
readRange (StateRef m l blk -> LedgerTablesHandle m l blk
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> LedgerTablesHandle m l blk
tables StateRef m l blk
stateRef) (StateRef m l blk -> l blk EmptyMK
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> l blk EmptyMK
state StateRef m l blk
stateRef) (TxIn blk -> Maybe (TxIn blk)
forall a. a -> Maybe a
Just TxIn blk
k, Int
n)

implForkerGetLedgerState ::
  (MonadSTM m, GetTip (l blk)) =>
  ForkerEnv m l blk ->
  STM m (l blk EmptyMK)
implForkerGetLedgerState :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(MonadSTM m, GetTip (l blk)) =>
ForkerEnv m l blk -> STM m (l blk EmptyMK)
implForkerGetLedgerState = (LedgerSeq m l blk -> l blk EmptyMK)
-> STM m (LedgerSeq m l blk) -> STM m (l blk EmptyMK)
forall a b. (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LedgerSeq m l blk -> l blk EmptyMK
forall (l :: * -> (* -> * -> *) -> *) blk (m :: * -> *).
GetTip (l blk) =>
LedgerSeq m l blk -> l blk EmptyMK
current (STM m (LedgerSeq m l blk) -> STM m (l blk EmptyMK))
-> (ForkerEnv m l blk -> STM m (LedgerSeq m l blk))
-> ForkerEnv m l blk
-> STM m (l blk EmptyMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m (LedgerSeq m l blk) -> STM m (LedgerSeq m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (LedgerSeq m l blk) -> STM m (LedgerSeq m l blk))
-> (ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk))
-> ForkerEnv m l blk
-> STM m (LedgerSeq m l blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
foeLedgerSeq

implForkerReadStatistics ::
  (MonadSTM m, GetTip (l blk)) =>
  ForkerEnv m l blk ->
  m Statistics
implForkerReadStatistics :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(MonadSTM m, GetTip (l blk)) =>
ForkerEnv m l blk -> m Statistics
implForkerReadStatistics ForkerEnv m l blk
env = do
  Tracer m TraceForkerEvent -> TraceForkerEvent -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
env) TraceForkerEvent
ForkerReadStatistics
  Int -> Statistics
Statistics (Int -> Statistics)
-> (LedgerSeq m l blk -> Int) -> LedgerSeq m l blk -> Statistics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTablesHandle m l blk -> Int
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
LedgerTablesHandle m l blk -> Int
tablesSize (LedgerTablesHandle m l blk -> Int)
-> (LedgerSeq m l blk -> LedgerTablesHandle m l blk)
-> LedgerSeq m l blk
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l blk -> LedgerTablesHandle m l blk
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> LedgerTablesHandle m l blk
tables (StateRef m l blk -> LedgerTablesHandle m l blk)
-> (LedgerSeq m l blk -> StateRef m l blk)
-> LedgerSeq m l blk
-> LedgerTablesHandle m l blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerSeq m l blk -> StateRef m l blk
forall (l :: * -> (* -> * -> *) -> *) blk (m :: * -> *).
GetTip (l blk) =>
LedgerSeq m l blk -> StateRef m l blk
currentHandle (LedgerSeq m l blk -> Statistics)
-> m (LedgerSeq m l blk) -> m Statistics
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (LedgerSeq m l blk) -> m (LedgerSeq m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
foeLedgerSeq ForkerEnv m l blk
env)

implForkerPush ::
  (IOLike m, GetTip (l blk), HasLedgerTables l blk, HasCallStack) =>
  ForkerEnv m l blk ->
  l blk DiffMK ->
  m ()
implForkerPush :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, GetTip (l blk), HasLedgerTables l blk, HasCallStack) =>
ForkerEnv m l blk -> l blk DiffMK -> m ()
implForkerPush ForkerEnv m l blk
env l blk DiffMK
newState = do
  Tracer m EnclosingTimed -> m () -> m ()
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (EnclosingTimed -> TraceForkerEvent
ForkerPush (EnclosingTimed -> TraceForkerEvent)
-> Tracer m TraceForkerEvent -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< ForkerEnv m l blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
env) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    lseq <- StrictTVar m (LedgerSeq m l blk) -> m (LedgerSeq m l blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l blk)
foeLedgerSeq ForkerEnv m l blk
env)
    let st0 = LedgerSeq m l blk -> l blk EmptyMK
forall (l :: * -> (* -> * -> *) -> *) blk (m :: * -> *).
GetTip (l blk) =>
LedgerSeq m l blk -> l blk EmptyMK
current LedgerSeq m l blk
lseq
        st = l blk DiffMK -> l blk EmptyMK
forall (l :: * -> (* -> * -> *) -> *) blk (mk :: * -> * -> *).
HasLedgerTables l blk =>
l blk mk -> l blk EmptyMK
forgetLedgerTables l blk DiffMK
newState

    -- We don't need to track this resource anywhere because if an exception
    -- comes here, the exception will abort ChainSel and therefore the node is
    -- shutting down so the resources (the Session in LSM) will be closed. See
    -- "Resource management in the LedgerDB" in
    -- "Ouroboros.Consensus.Storage.LedgerDB.API".
    tbs <- duplicateWithDiffs (tables $ currentHandle lseq) st0 newState
    atomically $ writeTVar (foeLedgerSeq env) (extend (StateRef st tbs) lseq)

implForkerCommit ::
  (IOLike m, GetTip (l blk), StandardHash (l blk)) =>
  ForkerEnv m l blk ->
  STM m (m ())
implForkerCommit :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, GetTip (l blk), StandardHash (l blk)) =>
ForkerEnv m l blk -> STM m (m ())
implForkerCommit ForkerEnv m l blk
env = do
  wasCommitted <- StrictTVar m Bool -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ForkerEnv m l blk -> StrictTVar m Bool
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m Bool
foeWasCommitted ForkerEnv m l blk
env)
  when wasCommitted $
    throw $
      CriticalInvariantViolation "Critical invariant violation: forker has been committed twice"
  LedgerSeq lseq <- readTVar (foeLedgerSeq env)
  let intersectionSlot = l blk EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot (l blk EmptyMK -> WithOrigin SlotNo)
-> l blk EmptyMK -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ StateRef m l blk -> l blk EmptyMK
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> l blk EmptyMK
state (StateRef m l blk -> l blk EmptyMK)
-> StateRef m l blk -> l blk EmptyMK
forall a b. (a -> b) -> a -> b
$ AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
-> StateRef m l blk
forall v a b. AnchoredSeq v a b -> a
AS.anchor AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
lseq
  let predicate = (ChainHash (l blk) -> ChainHash (l blk) -> Bool
forall a. Eq a => a -> a -> Bool
== l blk EmptyMK -> ChainHash (l blk)
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> ChainHash l
getTipHash (StateRef m l blk -> l blk EmptyMK
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> l blk EmptyMK
state (AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
-> StateRef m l blk
forall v a b. AnchoredSeq v a b -> a
AS.anchor AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
lseq))) (ChainHash (l blk) -> Bool)
-> (StateRef m l blk -> ChainHash (l blk))
-> StateRef m l blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l blk EmptyMK -> ChainHash (l blk)
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> ChainHash l
getTipHash (l blk EmptyMK -> ChainHash (l blk))
-> (StateRef m l blk -> l blk EmptyMK)
-> StateRef m l blk
-> ChainHash (l blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l blk -> l blk EmptyMK
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> l blk EmptyMK
state
  (toCloseForker, toCloseLdb) <-
    stateTVar
      (foeSwitchVar env)
      ( \(LedgerSeq AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
olddb) -> ((StateRef m l blk, Maybe (LedgerSeq m l blk)), LedgerSeq m l blk)
-> Maybe
     ((StateRef m l blk, Maybe (LedgerSeq m l blk)), LedgerSeq m l blk)
-> ((StateRef m l blk, Maybe (LedgerSeq m l blk)),
    LedgerSeq m l blk)
forall a. a -> Maybe a -> a
fromMaybe ((StateRef m l blk, Maybe (LedgerSeq m l blk)), LedgerSeq m l blk)
forall {a}. a
theImpossible (Maybe
   ((StateRef m l blk, Maybe (LedgerSeq m l blk)), LedgerSeq m l blk)
 -> ((StateRef m l blk, Maybe (LedgerSeq m l blk)),
     LedgerSeq m l blk))
-> Maybe
     ((StateRef m l blk, Maybe (LedgerSeq m l blk)), LedgerSeq m l blk)
-> ((StateRef m l blk, Maybe (LedgerSeq m l blk)),
    LedgerSeq m l blk)
forall a b. (a -> b) -> a -> b
$ do
          -- Split the selection at the intersection point. The snd component will
          -- have to be closed.
          (toKeepBase, toCloseLdb) <- WithOrigin SlotNo
-> (Either (StateRef m l blk) (StateRef m l blk) -> Bool)
-> AnchoredSeq
     (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
-> Maybe
     (AnchoredSeq
        (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk),
      AnchoredSeq
        (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk))
forall v a b.
Anchorable v a b =>
v
-> (Either a b -> Bool)
-> AnchoredSeq v a b
-> Maybe (AnchoredSeq v a b, AnchoredSeq v a b)
AS.splitAfterMeasure WithOrigin SlotNo
intersectionSlot ((StateRef m l blk -> Bool)
-> (StateRef m l blk -> Bool)
-> Either (StateRef m l blk) (StateRef m l blk)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either StateRef m l blk -> Bool
forall {m :: * -> *}. StateRef m l blk -> Bool
predicate StateRef m l blk -> Bool
forall {m :: * -> *}. StateRef m l blk -> Bool
predicate) AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
olddb
          -- Join the prefix of the selection with the sequence in the forker
          newdb <- AS.join (const $ const True) toKeepBase lseq
          -- Do /not/ close the anchor of @toClose@, as that is also the
          -- tip of @olddb'@ which will be used in @newdb@.
          let ldbToClose = case AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
toCloseLdb of
                AS.Empty StateRef m l blk
_ -> Maybe (LedgerSeq m l blk)
forall a. Maybe a
Nothing
                StateRef m l blk
_ AS.:< AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
closeOld' -> LedgerSeq m l blk -> Maybe (LedgerSeq m l blk)
forall a. a -> Maybe a
Just (AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
-> LedgerSeq m l blk
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
-> LedgerSeq m l blk
LedgerSeq AnchoredSeq
  (WithOrigin SlotNo) (StateRef m l blk) (StateRef m l blk)
closeOld')
          pure ((AS.anchor lseq, ldbToClose), LedgerSeq newdb)
      )
  writeTVar (foeWasCommitted env) True
  -- We put 'toCloseForker' in the LedgerSeq to then close it when closing the
  -- forker.
  writeTVar (foeLedgerSeq env) (LedgerSeq (AS.Empty toCloseForker))
  pure
    ( whenJust toCloseLdb $ \LedgerSeq m l blk
seqToClose ->
        RAWLock m () -> (() -> m ((), ())) -> m ()
forall (m :: * -> *) st a.
(MonadSTM m, MonadCatch m, MonadThrow (STM m)) =>
RAWLock m st -> (st -> m (a, st)) -> m a
withWriteAccess (ForkerEnv m l blk -> RAWLock m ()
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> RAWLock m ()
foeLedgerDbLock ForkerEnv m l blk
env) ((() -> m ((), ())) -> m ()) -> (() -> m ((), ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \() -> do
          LedgerSeq m l blk -> m ()
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
Monad m =>
LedgerSeq m l blk -> m ()
closeLedgerSeq LedgerSeq m l blk
seqToClose
          ((), ()) -> m ((), ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), ())
    )
 where
  theImpossible :: a
theImpossible =
    CriticalInvariantViolation -> a
forall a e. (HasCallStack, Exception e) => e -> a
throw (CriticalInvariantViolation -> a)
-> CriticalInvariantViolation -> a
forall a b. (a -> b) -> a -> b
$
      String -> CriticalInvariantViolation
CriticalInvariantViolation (String -> CriticalInvariantViolation)
-> String -> CriticalInvariantViolation
forall a b. (a -> b) -> a -> b
$
        Context -> String
unwords
          [ String
"Critical invariant violation:"
          , String
"Forker chain does no longer intersect with selected chain."
          ]

newtype CriticalInvariantViolation = CriticalInvariantViolation {CriticalInvariantViolation -> String
message :: String}
  deriving Int -> CriticalInvariantViolation -> ShowS
[CriticalInvariantViolation] -> ShowS
CriticalInvariantViolation -> String
(Int -> CriticalInvariantViolation -> ShowS)
-> (CriticalInvariantViolation -> String)
-> ([CriticalInvariantViolation] -> ShowS)
-> Show CriticalInvariantViolation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CriticalInvariantViolation -> ShowS
showsPrec :: Int -> CriticalInvariantViolation -> ShowS
$cshow :: CriticalInvariantViolation -> String
show :: CriticalInvariantViolation -> String
$cshowList :: [CriticalInvariantViolation] -> ShowS
showList :: [CriticalInvariantViolation] -> ShowS
Show
  deriving anyclass Show CriticalInvariantViolation
Typeable CriticalInvariantViolation
(Typeable CriticalInvariantViolation,
 Show CriticalInvariantViolation) =>
(CriticalInvariantViolation -> SomeException)
-> (SomeException -> Maybe CriticalInvariantViolation)
-> (CriticalInvariantViolation -> String)
-> (CriticalInvariantViolation -> Bool)
-> Exception CriticalInvariantViolation
SomeException -> Maybe CriticalInvariantViolation
CriticalInvariantViolation -> Bool
CriticalInvariantViolation -> String
CriticalInvariantViolation -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: CriticalInvariantViolation -> SomeException
toException :: CriticalInvariantViolation -> SomeException
$cfromException :: SomeException -> Maybe CriticalInvariantViolation
fromException :: SomeException -> Maybe CriticalInvariantViolation
$cdisplayException :: CriticalInvariantViolation -> String
displayException :: CriticalInvariantViolation -> String
$cbacktraceDesired :: CriticalInvariantViolation -> Bool
backtraceDesired :: CriticalInvariantViolation -> Bool
Exception