{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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.RAWLock (RAWLock)
import Control.ResourceRegistry
import Control.Tracer
import Data.Functor.Contravariant ((>$<))
import Data.Maybe (fromMaybe)
import GHC.Generics
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsProtocol
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)

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

data ForkerEnv m l blk = ForkerEnv
  { forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq :: !(StrictTVar m (LedgerSeq m l))
  -- ^ Local version of the LedgerSeq
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
foeSwitchVar :: !(StrictTVar m (LedgerSeq m l))
  -- ^ This TVar is the same as the LedgerDB one
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> ResourceRegistry m
foeLedgerDbRegistry :: !(ResourceRegistry m)
  -- ^ The registry in the LedgerDB to move handles to in case we commit the
  -- forker.
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m [LedgerSeq m l]
foeLedgerDbToClose :: !(StrictTVar m [LedgerSeq m l])
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer :: !(Tracer m TraceForkerEvent)
  -- ^ Config
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> ResourceRegistry m
foeResourceRegistry :: !(ResourceRegistry m)
  -- ^ The registry local to the forker
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> ResourceKey m
foeInitialHandleKey :: !(ResourceKey m)
  -- ^ Resource key for the initial handle to ensure it is released. See
  -- comments in 'implForkerCommit'.
  , forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (m ())
foeCleanup :: !(StrictTVar m (m ()))
  -- ^ An action to run on cleanup. If the forker was not committed this will be
  -- the trivial action. Otherwise it will move the required handles to the
  -- LedgerDB and release the discarded ones.
  , 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
  , LedgerSupportsProtocol blk
  , NoThunks (l EmptyMK)
  , NoThunks (TxIn l)
  , NoThunks (TxOut l)
  ) =>
  NoThunks (ForkerEnv m l blk)

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

implForkerRangeReadTables ::
  (IOLike m, GetTip l, HasLedgerTables l) =>
  QueryBatchSize ->
  ForkerEnv m l blk ->
  RangeQueryPrevious l ->
  m (LedgerTables l ValuesMK, Maybe (TxIn l))
implForkerRangeReadTables :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(IOLike m, GetTip l, HasLedgerTables l) =>
QueryBatchSize
-> ForkerEnv m l blk
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK, Maybe (TxIn l))
implForkerRangeReadTables QueryBatchSize
qbs ForkerEnv m l blk
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 blk -> Tracer m TraceForkerEvent
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> Tracer m TraceForkerEvent
foeTracer ForkerEnv m l blk
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
    ldb <- StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l))
-> StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall a b. (a -> b) -> a -> b
$ ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq ForkerEnv m l blk
env
    let 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
ldb
    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 blk ->
  STM m (l EmptyMK)
implForkerGetLedgerState :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(MonadSTM m, GetTip l) =>
ForkerEnv m l blk -> STM m (l EmptyMK)
implForkerGetLedgerState ForkerEnv m l blk
env = LedgerSeq m l -> l EmptyMK
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> l EmptyMK
current (LedgerSeq m l -> l EmptyMK)
-> STM m (LedgerSeq m l) -> STM m (l EmptyMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (LedgerSeq m l) -> STM m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq ForkerEnv m l blk
env)

implForkerReadStatistics ::
  (MonadSTM m, GetTip l) =>
  ForkerEnv m l blk ->
  m Statistics
implForkerReadStatistics :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(MonadSTM m, GetTip l) =>
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) -> m Int -> m Statistics
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Statistics
Statistics (m Int -> m Statistics)
-> (LedgerSeq m l -> m Int) -> LedgerSeq m l -> m Statistics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTablesHandle m l -> m Int
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> m Int
tablesSize (LedgerTablesHandle m l -> m Int)
-> (LedgerSeq m l -> LedgerTablesHandle m l)
-> LedgerSeq m l
-> m 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 -> m Statistics)
-> m (LedgerSeq m l) -> m Statistics
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StrictTVar m (LedgerSeq m l) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq ForkerEnv m l blk
env)

implForkerPush ::
  (IOLike m, GetTip l, HasLedgerTables l, HasCallStack) =>
  ForkerEnv m l blk ->
  l DiffMK ->
  m ()
implForkerPush :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(IOLike m, GetTip l, HasLedgerTables l, HasCallStack) =>
ForkerEnv m l blk -> l DiffMK -> m ()
implForkerPush ForkerEnv m l blk
env l DiffMK
newState =
  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) -> m (LedgerSeq m l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO (ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq ForkerEnv m l blk
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

    bracketOnError
      (duplicate (tables $ currentHandle lseq) (foeResourceRegistry env))
      (release . fst)
      ( \(ResourceKey m
_, LedgerTablesHandle m l
newtbs) -> do
          LedgerTablesHandle m l
-> forall (mk :: * -> * -> *). l mk -> l DiffMK -> m ()
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l
-> forall (mk :: * -> * -> *). l mk -> l DiffMK -> m ()
pushDiffs LedgerTablesHandle m l
newtbs l EmptyMK
st0 l DiffMK
newState

          let lseq' :: LedgerSeq m l
lseq' = StateRef m l -> LedgerSeq m l -> LedgerSeq m l
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
StateRef m l -> LedgerSeq m l -> LedgerSeq m l
extend (l EmptyMK -> LedgerTablesHandle m l -> StateRef m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
l EmptyMK -> LedgerTablesHandle m l -> StateRef m l
StateRef l EmptyMK
st LedgerTablesHandle m l
newtbs) LedgerSeq m l
lseq

          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
$ do
            StrictTVar m (LedgerSeq m l) -> LedgerSeq m l -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq ForkerEnv m l blk
env) LedgerSeq m l
lseq'
            StrictTVar m (m ()) -> (m () -> m ()) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (ForkerEnv m l blk -> StrictTVar m (m ())
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (m ())
foeCleanup ForkerEnv m l blk
env) (m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LedgerTablesHandle m l -> m ()
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> m ()
close LedgerTablesHandle m l
newtbs)
      )

implForkerCommit ::
  (IOLike m, GetTip l, StandardHash l) =>
  ForkerEnv m l blk ->
  STM m ()
implForkerCommit :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(IOLike m, GetTip l, StandardHash l) =>
ForkerEnv m l blk -> STM m ()
implForkerCommit ForkerEnv m l blk
env = do
  LedgerSeq lseq <- 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)
foeLedgerSeq
  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
  (transfer, ldbToClose) <-
    stateTVar
      foeSwitchVar
      ( \(LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
olddb) -> ((m (), Maybe (LedgerSeq m l)), LedgerSeq m l)
-> Maybe ((m (), Maybe (LedgerSeq m l)), LedgerSeq m l)
-> ((m (), Maybe (LedgerSeq m l)), LedgerSeq m l)
forall a. a -> Maybe a -> a
fromMaybe ((m (), Maybe (LedgerSeq m l)), LedgerSeq m l)
forall {a}. a
theImpossible (Maybe ((m (), Maybe (LedgerSeq m l)), LedgerSeq m l)
 -> ((m (), Maybe (LedgerSeq m l)), LedgerSeq m l))
-> Maybe ((m (), Maybe (LedgerSeq m l)), LedgerSeq m l)
-> ((m (), 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
          (toCloseForker, toKeepTip) <-
            AS.splitAfterMeasure intersectionSlot (either predicate predicate) lseq
          -- Join the prefix of the selection with the sequence in the forker
          newdb <- AS.join (const $ const True) toKeepBase toKeepTip
          -- 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')
              transferCommitted = do
                LedgerSeq m l -> m ()
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
Monad m =>
LedgerSeq m l -> m ()
closeLedgerSeq (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)
toCloseForker)

                -- All the other remaining handles are transferred to the LedgerDB registry
                keys <- ResourceRegistry m -> ResourceRegistry m -> m [ResourceKey m]
forall (m :: * -> *).
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
ResourceRegistry m -> ResourceRegistry m -> m [ResourceKey m]
transferRegistry ResourceRegistry m
foeResourceRegistry ResourceRegistry m
foeLedgerDbRegistry
                mapM_ (\(ResourceKey m
k, StateRef m l
v) -> LedgerTablesHandle m l -> ResourceKey m -> m ()
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> ResourceKey m -> m ()
transfer (StateRef m l -> LedgerTablesHandle m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> LedgerTablesHandle m l
tables StateRef m l
v) ResourceKey m
k) $ zip keys (AS.toOldestFirst toKeepTip)

          pure ((transferCommitted, ldbToClose), LedgerSeq newdb)
      )
  whenJust ldbToClose (modifyTVar foeLedgerDbToClose . (:))
  writeTVar foeCleanup transfer
  writeTVar foeWasCommitted True
 where
  ForkerEnv
    { StrictTVar m (LedgerSeq m l)
foeLedgerSeq :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
foeLedgerSeq :: StrictTVar m (LedgerSeq m l)
foeLedgerSeq
    , StrictTVar m (LedgerSeq m l)
foeSwitchVar :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (LedgerSeq m l)
foeSwitchVar :: StrictTVar m (LedgerSeq m l)
foeSwitchVar
    , ResourceRegistry m
foeResourceRegistry :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> ResourceRegistry m
foeResourceRegistry :: ResourceRegistry m
foeResourceRegistry
    , ResourceRegistry m
foeLedgerDbRegistry :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> ResourceRegistry m
foeLedgerDbRegistry :: ResourceRegistry m
foeLedgerDbRegistry
    , StrictTVar m (m ())
foeCleanup :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m (m ())
foeCleanup :: StrictTVar m (m ())
foeCleanup
    , StrictTVar m [LedgerSeq m l]
foeLedgerDbToClose :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m [LedgerSeq m l]
foeLedgerDbToClose :: StrictTVar m [LedgerSeq m l]
foeLedgerDbToClose
    , StrictTVar m Bool
foeWasCommitted :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk -> StrictTVar m Bool
foeWasCommitted :: StrictTVar m Bool
foeWasCommitted
    } = ForkerEnv m l blk
env

  theImpossible :: a
theImpossible =
    String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
      Context -> String
unwords
        [ String
"Critical invariant violation:"
        , String
"Forker chain does no longer intersect with selected chain."
        ]