{-# 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 hiding (read)
import Control.ResourceRegistry
import Control.Tracer
import Data.Maybe (fromMaybe)
import GHC.Generics
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
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.CallStack
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 -> SecurityParam
foeSecurityParam :: !SecurityParam
  -- ^ Config
  , 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 (), ResourceKey m, StrictTVar m (m ()))
foeResourcesToRelease :: !(RAWLock m (), ResourceKey m, StrictTVar m (m ()))
  -- ^ Release the resources
  }
  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 ::
  (MonadSTM m, GetTip l) =>
  ForkerEnv m l blk ->
  LedgerTables l KeysMK ->
  m (LedgerTables l ValuesMK)
implForkerReadTables :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(MonadSTM m, GetTip l) =>
ForkerEnv m l blk
-> LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)
implForkerReadTables ForkerEnv m l blk
env LedgerTables l KeysMK
ks = 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
ForkerReadTablesStart
  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)
  tbs <- read (tables $ currentHandle lseq) ks
  traceWith (foeTracer env) ForkerReadTablesEnd
  pure tbs

implForkerRangeReadTables ::
  (MonadSTM m, GetTip l, HasLedgerTables l) =>
  QueryBatchSize ->
  ForkerEnv m l blk ->
  RangeQueryPrevious l ->
  m (LedgerTables l ValuesMK)
implForkerRangeReadTables :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(MonadSTM m, GetTip l, HasLedgerTables l) =>
QueryBatchSize
-> ForkerEnv m l blk
-> RangeQueryPrevious l
-> m (LedgerTables l ValuesMK)
implForkerRangeReadTables QueryBatchSize
qbs ForkerEnv m l blk
env RangeQueryPrevious l
rq0 = 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
ForkerRangeReadTablesStart
  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
  case rq0 of
    RangeQueryPrevious l
NoPreviousQuery -> LedgerTablesHandle m l
-> (Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l
-> (Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK)
readRange (StateRef m l -> LedgerTablesHandle m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> LedgerTablesHandle m l
tables (StateRef m l -> LedgerTablesHandle m l)
-> StateRef m l -> LedgerTablesHandle m l
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l -> StateRef m l
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle LedgerSeq m l
ldb) (Maybe (TxIn l)
forall a. Maybe a
Nothing, Int
n)
    RangeQueryPrevious l
PreviousQueryWasFinal -> LedgerTables l ValuesMK -> m (LedgerTables l ValuesMK)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerTables l ValuesMK -> m (LedgerTables l ValuesMK))
-> LedgerTables l ValuesMK -> m (LedgerTables l ValuesMK)
forall a b. (a -> b) -> a -> b
$ 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
    PreviousQueryWasUpTo TxIn l
k -> do
      tbs <- LedgerTablesHandle m l
-> (Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l
-> (Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK)
readRange (StateRef m l -> LedgerTablesHandle m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> LedgerTablesHandle m l
tables (StateRef m l -> LedgerTablesHandle m l)
-> StateRef m l -> LedgerTablesHandle m l
forall a b. (a -> b) -> a -> b
$ LedgerSeq m l -> StateRef m l
forall (l :: (* -> * -> *) -> *) (m :: * -> *).
GetTip l =>
LedgerSeq m l -> StateRef m l
currentHandle LedgerSeq m l
ldb) (TxIn l -> Maybe (TxIn l)
forall a. a -> Maybe a
Just TxIn l
k, Int
n)
      traceWith (foeTracer env) ForkerRangeReadTablesEnd
      pure tbs

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 (Maybe Statistics)
implForkerReadStatistics :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
(MonadSTM m, GetTip l) =>
ForkerEnv m l blk -> m (Maybe 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
  (Maybe Int -> Maybe Statistics)
-> m (Maybe Int) -> m (Maybe 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) -> Maybe Int -> Maybe Statistics
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Statistics
Statistics) (m (Maybe Int) -> m (Maybe Statistics))
-> (LedgerSeq m l -> m (Maybe Int))
-> LedgerSeq m l
-> m (Maybe Statistics)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTablesHandle m l -> m (Maybe Int)
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> m (Maybe Int)
tablesSize (LedgerTablesHandle m l -> m (Maybe Int))
-> (LedgerSeq m l -> LedgerTablesHandle m l)
-> LedgerSeq m l
-> m (Maybe 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 (Maybe Statistics))
-> m (LedgerSeq m l) -> m (Maybe 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 = 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
ForkerPushStart
  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))
    close
    ( \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

        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
ForkerPushEnd
        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 ((\(RAWLock m ()
_, ResourceKey m
_, StrictTVar m (m ())
r) -> StrictTVar m (m ())
r) ((RAWLock m (), ResourceKey m, StrictTVar m (m ()))
 -> StrictTVar m (m ()))
-> (RAWLock m (), ResourceKey m, StrictTVar m (m ()))
-> StrictTVar m (m ())
forall a b. (a -> b) -> a -> b
$ ForkerEnv m l blk
-> (RAWLock m (), ResourceKey m, StrictTVar m (m ()))
forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk
-> (RAWLock m (), ResourceKey m, StrictTVar m (m ()))
foeResourcesToRelease 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
  closeDiscarded <- do
    stateTVar
      foeSwitchVar
      ( \(LedgerSeq AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
olddb) -> (m (), LedgerSeq m l)
-> Maybe (m (), LedgerSeq m l) -> (m (), LedgerSeq m l)
forall a. a -> Maybe a -> a
fromMaybe (m (), LedgerSeq m l)
forall {a}. a
theImpossible (Maybe (m (), LedgerSeq m l) -> (m (), LedgerSeq m l))
-> Maybe (m (), LedgerSeq m l) -> (m (), 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.
          (olddb', toClose) <- 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) olddb' lseq
          -- Prune the resulting sequence to keep @k@ states
          let (closePruned, s) = prune (LedgerDbPruneKeeping (foeSecurityParam env)) (LedgerSeq newdb)
              closeDiscarded = do
                m ()
closePruned
                -- Do /not/ close the anchor of @toClose@, as that is also the
                -- tip of @olddb'@ which will be used in @newdb@.
                case AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
toClose of
                  AS.Empty StateRef m l
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  StateRef m l
_ AS.:< AnchoredSeq (WithOrigin SlotNo) (StateRef m l) (StateRef m l)
closeOld' -> 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)
closeOld')
                -- Finally, close the anchor of @lseq@ (which is a duplicate of
                -- the head of @olddb'@).
                LedgerTablesHandle m l -> m ()
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
LedgerTablesHandle m l -> m ()
close (LedgerTablesHandle m l -> m ()) -> LedgerTablesHandle m l -> m ()
forall a b. (a -> b) -> a -> b
$ StateRef m l -> LedgerTablesHandle m l
forall (m :: * -> *) (l :: (* -> * -> *) -> *).
StateRef m l -> LedgerTablesHandle m l
tables (StateRef m l -> LedgerTablesHandle m l)
-> StateRef m l -> LedgerTablesHandle m l
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
          pure (closeDiscarded, s)
      )

  -- We are discarding the previous value in the TVar because we had accumulated
  -- actions for closing the states pushed to the forker. As we are committing
  -- those we have to close the ones discarded in this function and forget about
  -- those releasing actions.
  writeTVar ((\(RAWLock m ()
_, ResourceKey m
_, StrictTVar m (m ())
r) -> StrictTVar m (m ())
r) $ foeResourcesToRelease) closeDiscarded
 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
    , (RAWLock m (), ResourceKey m, StrictTVar m (m ()))
foeResourcesToRelease :: forall (m :: * -> *) (l :: (* -> * -> *) -> *) blk.
ForkerEnv m l blk
-> (RAWLock m (), ResourceKey m, StrictTVar m (m ()))
foeResourcesToRelease :: (RAWLock m (), ResourceKey m, StrictTVar m (m ()))
foeResourcesToRelease
    } = 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."
        ]