{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# 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 = ForkerEnv
  { forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq :: !(StrictTVar m (LedgerSeq m l))
  -- ^ Local version of the LedgerSeq
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> StrictTVar m (LedgerSeq m l)
foeSwitchVar :: !(StrictTVar m (LedgerSeq m l))
  -- ^ This TVar is the same as the LedgerDB one
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> Tracer m TraceForkerEvent
foeTracer :: !(Tracer m TraceForkerEvent)
  -- ^ Config
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> RAWLock m ()
foeLedgerDbLock :: !(RAWLock m ())
  -- ^ 'ldbOpenHandlesLock'.
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> StrictTVar m Bool
foeWasCommitted :: !(StrictTVar m Bool)
  }
  deriving (forall x. ForkerEnv m l -> Rep (ForkerEnv m l) x)
-> (forall x. Rep (ForkerEnv m l) x -> ForkerEnv m l)
-> Generic (ForkerEnv m l)
forall x. Rep (ForkerEnv m l) x -> ForkerEnv m l
forall x. ForkerEnv m l -> Rep (ForkerEnv m l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
Rep (ForkerEnv m l) x -> ForkerEnv m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
ForkerEnv m l -> Rep (ForkerEnv m l) x
$cfrom :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
ForkerEnv m l -> Rep (ForkerEnv m l) x
from :: forall x. ForkerEnv m l -> Rep (ForkerEnv m l) x
$cto :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) x.
Rep (ForkerEnv m l) x -> ForkerEnv m l
to :: forall x. Rep (ForkerEnv m l) x -> ForkerEnv m l
Generic

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

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

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

implForkerRangeReadTables ::
  (IOLike m, GetTip l, HasLedgerTables l) =>
  QueryBatchSize ->
  ForkerEnv m l ->
  RangeQueryPrevious l ->
  m (LedgerTables l ValuesMK, Maybe (TxIn l))
implForkerRangeReadTables :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
(IOLike m, GetTip l, HasLedgerTables l) =>
QueryBatchSize
-> ForkerEnv m l
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
implForkerRangeReadTables QueryBatchSize
qbs ForkerEnv m l
env RangeQueryPrevious l
rq0 =
  Tracer m EnclosingTimed
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
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 -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l
env) (m (LedgerTables l ValuesMK, Maybe (TxIn l))
 -> m (LedgerTables l ValuesMK, Maybe (TxIn l)))
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
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 -> StateRef m l
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle (LedgerSeq m l -> StateRef m l)
-> m (LedgerSeq m l) -> m (StateRef m l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq ForkerEnv m l
env)
    case rq0 of
      RangeQueryPrevious l
NoPreviousQuery -> LedgerTablesHandle m l
-> l EmptyMK
-> (Maybe (TxIn l), Int)
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l
-> l EmptyMK
-> (Maybe (TxIn l), Int)
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
readRange (StateRef m l -> LedgerTablesHandle m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> LedgerTablesHandle m l
tables StateRef m l
stateRef) (StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state StateRef m l
stateRef) (Maybe (TxIn l)
forall a. Maybe a
Nothing, Int
n)
      RangeQueryPrevious l
PreviousQueryWasFinal -> (LedgerTables l ValuesMK, Maybe (TxIn l))
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValuesMK (TxIn l) (TxOut l) -> LedgerTables l ValuesMK
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables ValuesMK (TxIn l) (TxOut l)
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 l)
forall a. Maybe a
Nothing)
      PreviousQueryWasUpTo TxIn l
k ->
        LedgerTablesHandle m l
-> l EmptyMK
-> (Maybe (TxIn l), Int)
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l
-> l EmptyMK
-> (Maybe (TxIn l), Int)
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
readRange (StateRef m l -> LedgerTablesHandle m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> LedgerTablesHandle m l
tables StateRef m l
stateRef) (StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state StateRef m l
stateRef) (TxIn l -> Maybe (TxIn l)
forall a. a -> Maybe a
Just TxIn l
k, Int
n)

implForkerGetLedgerState ::
  (MonadSTM m, GetTip l) =>
  ForkerEnv m l ->
  STM m (l EmptyMK)
implForkerGetLedgerState :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
(MonadSTM m, GetTip l) =>
ForkerEnv m l -> STM m (l EmptyMK)
implForkerGetLedgerState = (LedgerSeq m l -> l EmptyMK)
-> STM m (LedgerSeq m l) -> STM m (l 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 -> l EmptyMK
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current (STM m (LedgerSeq m l) -> STM m (l EmptyMK))
-> (ForkerEnv m l -> STM m (LedgerSeq m l))
-> ForkerEnv m l
-> STM m (l EmptyMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m (LedgerSeq m l) -> STM m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (LedgerSeq m l) -> STM m (LedgerSeq m l))
-> (ForkerEnv m l -> StrictTVar m (LedgerSeq m l))
-> ForkerEnv m l
-> STM m (LedgerSeq m l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForkerEnv m l -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq

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

implForkerPush ::
  (IOLike m, GetTip l, HasLedgerTables l, HasCallStack) =>
  ForkerEnv m l ->
  l DiffMK ->
  m ()
implForkerPush :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
(IOLike m, GetTip l, HasLedgerTables l, HasCallStack) =>
ForkerEnv m l -> l DiffMK -> m ()
implForkerPush ForkerEnv m l
env l 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 -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l
env) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    lseq <- StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq ForkerEnv m l
env)
    let st0 = LedgerSeq m l -> l EmptyMK
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current LedgerSeq m l
lseq
        st = l DiffMK -> l EmptyMK
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables l 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, StandardHash l) =>
  ForkerEnv m l ->
  STM m (m ())
implForkerCommit :: forall (m :: * -> *) (l :: (* -> * -> *) -> *).
(IOLike m, GetTip l, StandardHash l) =>
ForkerEnv m l -> STM m (m ())
implForkerCommit ForkerEnv m l
env = do
  wasCommitted <- StrictTVar m Bool -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ForkerEnv m l -> StrictTVar m Bool
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> StrictTVar m Bool
foeWasCommitted ForkerEnv m l
env)
  when wasCommitted $
    throw $
      CriticalInvariantViolation "Critical invariant violation: forker has been committed twice"
  LedgerSeq lseq <- readTVar (foeLedgerSeq env)
  let intersectionSlot = l EmptyMK -> WithOrigin SlotNo
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot (l EmptyMK -> WithOrigin SlotNo) -> l EmptyMK -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state (StateRef m l -> l EmptyMK) -> StateRef m l -> l EmptyMK
forall a b. (a -> b) -> a -> b
$ AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> StateRef m l
forall v a b. AnchoredSeq v a b -> a
AS.anchor AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
lseq
  let predicate = (ChainHash l -> ChainHash l -> Bool
forall a. Eq a => a -> a -> Bool
== l EmptyMK -> ChainHash l
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> ChainHash l
getTipHash (StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> StateRef m l
forall v a b. AnchoredSeq v a b -> a
AS.anchor AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
lseq))) (ChainHash l -> Bool)
-> (StateRef m l -> ChainHash l) -> StateRef m l -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l EmptyMK -> ChainHash l
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip l =>
l mk -> ChainHash l
getTipHash (l EmptyMK -> ChainHash l)
-> (StateRef m l -> l EmptyMK) -> StateRef m l -> ChainHash l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef m l -> l EmptyMK
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> l EmptyMK
state
  (toCloseForker, toCloseLdb) <-
    stateTVar
      (foeSwitchVar env)
      ( \(LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
olddb) -> ((StateRef m l, Maybe (LedgerSeq m l)), LedgerSeq m l)
-> Maybe ((StateRef m l, Maybe (LedgerSeq m l)), LedgerSeq m l)
-> ((StateRef m l, Maybe (LedgerSeq m l)), LedgerSeq m l)
forall a. a -> Maybe a -> a
fromMaybe ((StateRef m l, Maybe (LedgerSeq m l)), LedgerSeq m l)
forall {a}. a
theImpossible (Maybe ((StateRef m l, Maybe (LedgerSeq m l)), LedgerSeq m l)
 -> ((StateRef m l, Maybe (LedgerSeq m l)), LedgerSeq m l))
-> Maybe ((StateRef m l, Maybe (LedgerSeq m l)), LedgerSeq m l)
-> ((StateRef m l, Maybe (LedgerSeq m l)), LedgerSeq m l)
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) (StateRef m l) -> Bool)
-> AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> Maybe
     (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l),
      AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l))
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 -> Bool)
-> (StateRef m l -> Bool)
-> Either (StateRef m l) (StateRef m l)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either StateRef m l -> Bool
forall {m :: * -> *}. StateRef m l -> Bool
predicate StateRef m l -> Bool
forall {m :: * -> *}. StateRef m l -> Bool
predicate) AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
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) (StateRef m l)
toCloseLdb of
                AS.Empty StateRef m l
_ -> Maybe (LedgerSeq m l)
forall a. Maybe a
Nothing
                StateRef m l
_ AS.:< AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
closeOld' -> LedgerSeq m l -> Maybe (LedgerSeq m l)
forall a. a -> Maybe a
Just (AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
-> LedgerSeq m l
LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
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
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 -> RAWLock m ()
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
ForkerEnv m l -> RAWLock m ()
foeLedgerDbLock ForkerEnv m l
env) ((() -> m ((), ())) -> m ()) -> (() -> m ((), ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \() -> do
          LedgerSeq m l -> m ()
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Monad m =>
LedgerSeq m l -> m ()
closeLedgerSeq LedgerSeq m l
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