{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE PatternSynonyms          #-}
{-# LANGUAGE RecordWildCards          #-}
{-# LANGUAGE ScopedTypeVariables      #-}

module Ouroboros.Consensus.Storage.ChainDB.Impl (
    -- * Initialization
    ChainDbArgs (..)
  , SerialiseDiskConstraints
  , defaultArgs
  , openDB
  , withDB
    -- * Trace types
  , LgrDB.TraceReplayEvent
  , NewTipInfo (..)
  , TraceAddBlockEvent (..)
  , TraceCopyToImmutableDBEvent (..)
  , TraceEvent (..)
  , TraceFollowerEvent (..)
  , TraceGCEvent (..)
  , TraceInitChainSelEvent (..)
  , TraceIteratorEvent (..)
  , TraceOpenEvent (..)
  , TracePipeliningEvent (..)
  , TraceValidationEvent (..)
    -- * Re-exported for convenience
  , Args.RelativeMountPoint (..)
  , ImmutableDB.ImmutableDbSerialiseConstraints
  , LgrDB.LgrDbSerialiseConstraints
  , VolatileDB.VolatileDbSerialiseConstraints
    -- * Internals for testing purposes
  , Internal (..)
  , openDBInternal
  ) where

import           Control.Monad (when)
import           Control.Monad.Trans.Class (lift)
import           Control.Tracer
import           Data.Functor ((<&>))
import           Data.Functor.Identity (Identity)
import qualified Data.Map.Strict as Map
import           Data.Maybe.Strict (StrictMaybe (..))
import           GHC.Stack (HasCallStack)

import qualified Ouroboros.Network.AnchoredFragment as AF

import           Ouroboros.Consensus.Block
import qualified Ouroboros.Consensus.Fragment.Validated as VF
import           Ouroboros.Consensus.HardFork.Abstract
import           Ouroboros.Consensus.Ledger.Inspect
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Util (whenJust)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.STM (Fingerprint (..),
                     WithFingerprint (..))

import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as API
import           Ouroboros.Consensus.Util.ResourceRegistry (WithTempRegistry,
                     allocate, runInnerWithTempRegistry, runWithTempRegistry)

import           Ouroboros.Consensus.Storage.ChainDB.Impl.Args (ChainDbArgs,
                     defaultArgs)
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as Args
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Background as Background
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel as ChainSel
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Follower as Follower
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Iterator as Iterator
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LgrDB
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Query as Query
import           Ouroboros.Consensus.Storage.ChainDB.Impl.Types
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
import           Ouroboros.Consensus.Util.TentativeState
                     (TentativeState (NoLastInvalidTentative))

{-------------------------------------------------------------------------------
  Initialization
-------------------------------------------------------------------------------}

withDB
  :: forall m blk a.
     ( IOLike m
     , LedgerSupportsProtocol blk
     , InspectLedger blk
     , HasHardForkHistory blk
     , ConvertRawHash blk
     , SerialiseDiskConstraints blk
     )
  => ChainDbArgs Identity m blk
  -> (ChainDB m blk -> m a)
  -> m a
withDB :: ChainDbArgs Identity m blk -> (ChainDB m blk -> m a) -> m a
withDB ChainDbArgs Identity m blk
args = m (ChainDB m blk)
-> (ChainDB m blk -> m ()) -> (ChainDB m blk -> m a) -> m a
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket ((ChainDB m blk, Internal m blk) -> ChainDB m blk
forall a b. (a, b) -> a
fst ((ChainDB m blk, Internal m blk) -> ChainDB m blk)
-> m (ChainDB m blk, Internal m blk) -> m (ChainDB m blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDbArgs Identity m blk
-> Bool -> m (ChainDB m blk, Internal m blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk) =>
ChainDbArgs Identity m blk
-> Bool -> m (ChainDB m blk, Internal m blk)
openDBInternal ChainDbArgs Identity m blk
args Bool
True) ChainDB m blk -> m ()
forall (m :: * -> *) blk. ChainDB m blk -> m ()
API.closeDB

openDB
  :: forall m blk.
     ( IOLike m
     , LedgerSupportsProtocol blk
     , InspectLedger blk
     , HasHardForkHistory blk
     , ConvertRawHash blk
     , SerialiseDiskConstraints blk
     )
  => ChainDbArgs Identity m blk
  -> m (ChainDB m blk)
openDB :: ChainDbArgs Identity m blk -> m (ChainDB m blk)
openDB ChainDbArgs Identity m blk
args = (ChainDB m blk, Internal m blk) -> ChainDB m blk
forall a b. (a, b) -> a
fst ((ChainDB m blk, Internal m blk) -> ChainDB m blk)
-> m (ChainDB m blk, Internal m blk) -> m (ChainDB m blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDbArgs Identity m blk
-> Bool -> m (ChainDB m blk, Internal m blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk) =>
ChainDbArgs Identity m blk
-> Bool -> m (ChainDB m blk, Internal m blk)
openDBInternal ChainDbArgs Identity m blk
args Bool
True

openDBInternal
  :: forall m blk.
     ( IOLike m
     , LedgerSupportsProtocol blk
     , InspectLedger blk
     , HasHardForkHistory blk
     , ConvertRawHash blk
     , SerialiseDiskConstraints blk
     )
  => ChainDbArgs Identity m blk
  -> Bool -- ^ 'True' = Launch background tasks
  -> m (ChainDB m blk, Internal m blk)
openDBInternal :: ChainDbArgs Identity m blk
-> Bool -> m (ChainDB m blk, Internal m blk)
openDBInternal ChainDbArgs Identity m blk
args Bool
launchBgTasks = WithTempRegistry
  (ChainDbEnv m blk)
  m
  ((ChainDB m blk, Internal m blk), ChainDbEnv m blk)
-> m (ChainDB m blk, Internal m blk)
forall (m :: * -> *) st a.
(IOLike m, HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry (WithTempRegistry
   (ChainDbEnv m blk)
   m
   ((ChainDB m blk, Internal m blk), ChainDbEnv m blk)
 -> m (ChainDB m blk, Internal m blk))
-> WithTempRegistry
     (ChainDbEnv m blk)
     m
     ((ChainDB m blk, Internal m blk), ChainDbEnv m blk)
-> m (ChainDB m blk, Internal m blk)
forall a b. (a -> b) -> a -> b
$ do
    m () -> WithTempRegistry (ChainDbEnv m blk) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (ChainDbEnv m blk) m ())
-> m () -> WithTempRegistry (ChainDbEnv m blk) m ()
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ TraceOpenEvent blk -> TraceEvent blk
forall blk. TraceOpenEvent blk -> TraceEvent blk
TraceOpenEvent TraceOpenEvent blk
forall blk. TraceOpenEvent blk
StartedOpeningDB
    m () -> WithTempRegistry (ChainDbEnv m blk) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (ChainDbEnv m blk) m ())
-> m () -> WithTempRegistry (ChainDbEnv m blk) m ()
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ TraceOpenEvent blk -> TraceEvent blk
forall blk. TraceOpenEvent blk -> TraceEvent blk
TraceOpenEvent TraceOpenEvent blk
forall blk. TraceOpenEvent blk
StartedOpeningImmutableDB
    ImmutableDB m blk
immutableDB <- ImmutableDbArgs Identity m blk
-> (forall st.
    WithTempRegistry st m (ImmutableDB m blk, st)
    -> WithTempRegistry (ChainDbEnv m blk) m (ImmutableDB m blk))
-> WithTempRegistry (ChainDbEnv m blk) m (ImmutableDB m blk)
forall (m :: * -> *) blk ans.
(IOLike m, GetPrevHash blk, ConvertRawHash blk,
 ImmutableDbSerialiseConstraints blk, HasCallStack) =>
ImmutableDbArgs Identity m blk
-> (forall st.
    WithTempRegistry st m (ImmutableDB m blk, st) -> ans)
-> ans
ImmutableDB.openDB ImmutableDbArgs Identity m blk
argsImmutableDb ((forall st.
  WithTempRegistry st m (ImmutableDB m blk, st)
  -> WithTempRegistry (ChainDbEnv m blk) m (ImmutableDB m blk))
 -> WithTempRegistry (ChainDbEnv m blk) m (ImmutableDB m blk))
-> (forall st.
    WithTempRegistry st m (ImmutableDB m blk, st)
    -> WithTempRegistry (ChainDbEnv m blk) m (ImmutableDB m blk))
-> WithTempRegistry (ChainDbEnv m blk) m (ImmutableDB m blk)
forall a b. (a -> b) -> a -> b
$ (ImmutableDB m blk -> m ())
-> WithTempRegistry st m (ImmutableDB m blk, st)
-> WithTempRegistry (ChainDbEnv m blk) m (ImmutableDB m blk)
forall (m :: * -> *) innerDB st blk.
IOLike m =>
(innerDB -> m ())
-> WithTempRegistry st m (innerDB, st)
-> WithTempRegistry (ChainDbEnv m blk) m innerDB
innerOpenCont ImmutableDB m blk -> m ()
forall (m :: * -> *) blk. HasCallStack => ImmutableDB m blk -> m ()
ImmutableDB.closeDB
    Point blk
immutableDbTipPoint <- m (Point blk) -> WithTempRegistry (ChainDbEnv m blk) m (Point blk)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Point blk)
 -> WithTempRegistry (ChainDbEnv m blk) m (Point blk))
-> m (Point blk)
-> WithTempRegistry (ChainDbEnv m blk) m (Point blk)
forall a b. (a -> b) -> a -> b
$ STM m (Point blk) -> m (Point blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Point blk) -> m (Point blk))
-> STM m (Point blk) -> m (Point blk)
forall a b. (a -> b) -> a -> b
$ ImmutableDB m blk -> STM m (Point blk)
forall (m :: * -> *) blk.
(MonadSTM m, HasCallStack) =>
ImmutableDB m blk -> STM m (Point blk)
ImmutableDB.getTipPoint ImmutableDB m blk
immutableDB
    let immutableDbTipChunk :: ChunkNo
immutableDbTipChunk =
          ChunkInfo -> Point blk -> ChunkNo
forall blk. ChunkInfo -> Point blk -> ChunkNo
chunkIndexOfPoint (ChainDbArgs Identity m blk -> HKD Identity ChunkInfo
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> HKD f ChunkInfo
Args.cdbChunkInfo ChainDbArgs Identity m blk
args) Point blk
immutableDbTipPoint
    m () -> WithTempRegistry (ChainDbEnv m blk) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (ChainDbEnv m blk) m ())
-> m () -> WithTempRegistry (ChainDbEnv m blk) m ()
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$
      TraceOpenEvent blk -> TraceEvent blk
forall blk. TraceOpenEvent blk -> TraceEvent blk
TraceOpenEvent (TraceOpenEvent blk -> TraceEvent blk)
-> TraceOpenEvent blk -> TraceEvent blk
forall a b. (a -> b) -> a -> b
$
        Point blk -> ChunkNo -> TraceOpenEvent blk
forall blk. Point blk -> ChunkNo -> TraceOpenEvent blk
OpenedImmutableDB Point blk
immutableDbTipPoint ChunkNo
immutableDbTipChunk

    m () -> WithTempRegistry (ChainDbEnv m blk) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WithTempRegistry (ChainDbEnv m blk) m ())
-> m () -> WithTempRegistry (ChainDbEnv m blk) m ()
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ TraceOpenEvent blk -> TraceEvent blk
forall blk. TraceOpenEvent blk -> TraceEvent blk
TraceOpenEvent TraceOpenEvent blk
forall blk. TraceOpenEvent blk
StartedOpeningVolatileDB
    VolatileDB m blk
volatileDB <- VolatileDbArgs Identity m blk
-> (forall st.
    WithTempRegistry st m (VolatileDB m blk, st)
    -> WithTempRegistry (ChainDbEnv m blk) m (VolatileDB m blk))
-> WithTempRegistry (ChainDbEnv m blk) m (VolatileDB m blk)
forall (m :: * -> *) blk ans.
(HasCallStack, IOLike m, HasHeader blk, GetPrevHash blk,
 VolatileDbSerialiseConstraints blk) =>
VolatileDbArgs Identity m blk
-> (forall st. WithTempRegistry st m (VolatileDB m blk, st) -> ans)
-> ans
VolatileDB.openDB VolatileDbArgs Identity m blk
argsVolatileDb ((forall st.
  WithTempRegistry st m (VolatileDB m blk, st)
  -> WithTempRegistry (ChainDbEnv m blk) m (VolatileDB m blk))
 -> WithTempRegistry (ChainDbEnv m blk) m (VolatileDB m blk))
-> (forall st.
    WithTempRegistry st m (VolatileDB m blk, st)
    -> WithTempRegistry (ChainDbEnv m blk) m (VolatileDB m blk))
-> WithTempRegistry (ChainDbEnv m blk) m (VolatileDB m blk)
forall a b. (a -> b) -> a -> b
$ (VolatileDB m blk -> m ())
-> WithTempRegistry st m (VolatileDB m blk, st)
-> WithTempRegistry (ChainDbEnv m blk) m (VolatileDB m blk)
forall (m :: * -> *) innerDB st blk.
IOLike m =>
(innerDB -> m ())
-> WithTempRegistry st m (innerDB, st)
-> WithTempRegistry (ChainDbEnv m blk) m innerDB
innerOpenCont VolatileDB m blk -> m ()
forall (m :: * -> *) blk. VolatileDB m blk -> HasCallStack => m ()
VolatileDB.closeDB
    (ChainDB m blk
chainDB, Internal m blk
testing, ChainDbEnv m blk
env) <- m (ChainDB m blk, Internal m blk, ChainDbEnv m blk)
-> WithTempRegistry
     (ChainDbEnv m blk)
     m
     (ChainDB m blk, Internal m blk, ChainDbEnv m blk)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ChainDB m blk, Internal m blk, ChainDbEnv m blk)
 -> WithTempRegistry
      (ChainDbEnv m blk)
      m
      (ChainDB m blk, Internal m blk, ChainDbEnv m blk))
-> m (ChainDB m blk, Internal m blk, ChainDbEnv m blk)
-> WithTempRegistry
     (ChainDbEnv m blk)
     m
     (ChainDB m blk, Internal m blk, ChainDbEnv m blk)
forall a b. (a -> b) -> a -> b
$ do
      Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ TraceOpenEvent blk -> TraceEvent blk
forall blk. TraceOpenEvent blk -> TraceEvent blk
TraceOpenEvent TraceOpenEvent blk
forall blk. TraceOpenEvent blk
OpenedVolatileDB
      let lgrReplayTracer :: Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
lgrReplayTracer =
            Point blk
-> Tracer m (TraceReplayEvent blk)
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
forall blk (m :: * -> *).
Point blk
-> Tracer m (TraceReplayEvent blk)
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
LgrDB.decorateReplayTracerWithGoal
              Point blk
immutableDbTipPoint
              ((TraceReplayEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceReplayEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap TraceReplayEvent blk -> TraceEvent blk
forall blk. TraceReplayEvent blk -> TraceEvent blk
TraceLedgerReplayEvent Tracer m (TraceEvent blk)
tracer)
      Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ TraceOpenEvent blk -> TraceEvent blk
forall blk. TraceOpenEvent blk -> TraceEvent blk
TraceOpenEvent TraceOpenEvent blk
forall blk. TraceOpenEvent blk
StartedOpeningLgrDB
      (LgrDB m blk
lgrDB, Word64
replayed) <- LgrDbArgs Identity m blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> ImmutableDB m blk
-> (RealPoint blk -> m blk)
-> m (LgrDB m blk, Word64)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 LgrDbSerialiseConstraints blk, InspectLedger blk, HasCallStack) =>
LgrDbArgs Identity m blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> ImmutableDB m blk
-> (RealPoint blk -> m blk)
-> m (LgrDB m blk, Word64)
LgrDB.openDB LgrDbArgs Identity m blk
argsLgrDb
                            Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
lgrReplayTracer
                            ImmutableDB m blk
immutableDB
                            (ImmutableDB m blk -> VolatileDB m blk -> RealPoint blk -> m blk
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
ImmutableDB m blk -> VolatileDB m blk -> RealPoint blk -> m blk
Query.getAnyKnownBlock ImmutableDB m blk
immutableDB VolatileDB m blk
volatileDB)
      Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ TraceOpenEvent blk -> TraceEvent blk
forall blk. TraceOpenEvent blk -> TraceEvent blk
TraceOpenEvent TraceOpenEvent blk
forall blk. TraceOpenEvent blk
OpenedLgrDB

      StrictTVar
  m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
varInvalid      <- WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk))
-> m (StrictTVar
        m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk))))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (Map (HeaderHash blk) (InvalidBlockInfo blk)
-> Fingerprint
-> WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk))
forall a. a -> Fingerprint -> WithFingerprint a
WithFingerprint Map (HeaderHash blk) (InvalidBlockInfo blk)
forall k a. Map k a
Map.empty (Word64 -> Fingerprint
Fingerprint Word64
0))
      StrictTVar
  m (Map (HeaderHash blk) (Header blk, InvalidBlockPunishment m))
varFutureBlocks <- Map (HeaderHash blk) (Header blk, InvalidBlockPunishment m)
-> m (StrictTVar
        m (Map (HeaderHash blk) (Header blk, InvalidBlockPunishment m)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Map (HeaderHash blk) (Header blk, InvalidBlockPunishment m)
forall k a. Map k a
Map.empty

      let initChainSelTracer :: Tracer m (TraceInitChainSelEvent blk)
initChainSelTracer = (TraceInitChainSelEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk)
-> Tracer m (TraceInitChainSelEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap TraceInitChainSelEvent blk -> TraceEvent blk
forall blk. TraceInitChainSelEvent blk -> TraceEvent blk
TraceInitChainSelEvent Tracer m (TraceEvent blk)
tracer

      Tracer m (TraceInitChainSelEvent blk)
-> TraceInitChainSelEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceInitChainSelEvent blk)
initChainSelTracer TraceInitChainSelEvent blk
forall blk. TraceInitChainSelEvent blk
StartedInitChainSelection
      ChainAndLedger blk
chainAndLedger <- ImmutableDB m blk
-> VolatileDB m blk
-> LgrDB m blk
-> Tracer m (TraceInitChainSelEvent blk)
-> TopLevelConfig blk
-> StrictTVar
     m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
-> StrictTVar
     m (Map (HeaderHash blk) (Header blk, InvalidBlockPunishment m))
-> CheckInFuture m blk
-> m (ChainAndLedger blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
ImmutableDB m blk
-> VolatileDB m blk
-> LgrDB m blk
-> Tracer m (TraceInitChainSelEvent blk)
-> TopLevelConfig blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> StrictTVar m (FutureBlocks m blk)
-> CheckInFuture m blk
-> m (ChainAndLedger blk)
ChainSel.initialChainSelection
                          ImmutableDB m blk
immutableDB
                          VolatileDB m blk
volatileDB
                          LgrDB m blk
lgrDB
                          Tracer m (TraceInitChainSelEvent blk)
initChainSelTracer
                          (ChainDbArgs Identity m blk -> HKD Identity (TopLevelConfig blk)
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> HKD f (TopLevelConfig blk)
Args.cdbTopLevelConfig ChainDbArgs Identity m blk
args)
                          StrictTVar
  m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
varInvalid
                          StrictTVar
  m (Map (HeaderHash blk) (Header blk, InvalidBlockPunishment m))
varFutureBlocks
                          (ChainDbArgs Identity m blk -> HKD Identity (CheckInFuture m blk)
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> HKD f (CheckInFuture m blk)
Args.cdbCheckInFuture ChainDbArgs Identity m blk
args)
      Tracer m (TraceInitChainSelEvent blk)
-> TraceInitChainSelEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceInitChainSelEvent blk)
initChainSelTracer TraceInitChainSelEvent blk
forall blk. TraceInitChainSelEvent blk
InitalChainSelected

      let chain :: AnchoredFragment (Header blk)
chain  = ChainAndLedger blk -> AnchoredFragment (Header blk)
forall b l. ValidatedFragment b l -> AnchoredFragment b
VF.validatedFragment ChainAndLedger blk
chainAndLedger
          ledger :: LedgerDB' blk
ledger = ChainAndLedger blk -> LedgerDB' blk
forall b l. ValidatedFragment b l -> l
VF.validatedLedger   ChainAndLedger blk
chainAndLedger
          cfg :: HKD Identity (TopLevelConfig blk)
cfg    = ChainDbArgs Identity m blk -> HKD Identity (TopLevelConfig blk)
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> HKD f (TopLevelConfig blk)
Args.cdbTopLevelConfig ChainDbArgs Identity m blk
args

      STM m () -> m ()
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
$ LgrDB m blk -> LedgerDB' blk -> STM m ()
forall (m :: * -> *) blk.
IOLike m =>
LgrDB m blk -> LedgerDB' blk -> STM m ()
LgrDB.setCurrent LgrDB m blk
lgrDB LedgerDB' blk
ledger
      StrictTVar m (AnchoredFragment (Header blk))
varChain           <- AnchoredFragment (Header blk)
-> m (StrictTVar m (AnchoredFragment (Header blk)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO AnchoredFragment (Header blk)
chain
      StrictTVar m (TentativeState blk)
varTentativeState  <- TentativeState blk -> m (StrictTVar m (TentativeState blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO TentativeState blk
forall blk. TentativeState blk
NoLastInvalidTentative
      StrictTVar m (StrictMaybe (Header blk))
varTentativeHeader <- StrictMaybe (Header blk)
-> m (StrictTVar m (StrictMaybe (Header blk)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO StrictMaybe (Header blk)
forall a. StrictMaybe a
SNothing
      StrictTVar m (Map IteratorKey (m ()))
varIterators       <- Map IteratorKey (m ()) -> m (StrictTVar m (Map IteratorKey (m ())))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Map IteratorKey (m ())
forall k a. Map k a
Map.empty
      StrictTVar m (Map FollowerKey (FollowerHandle m blk))
varFollowers       <- Map FollowerKey (FollowerHandle m blk)
-> m (StrictTVar m (Map FollowerKey (FollowerHandle m blk)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Map FollowerKey (FollowerHandle m blk)
forall k a. Map k a
Map.empty
      StrictTVar m IteratorKey
varNextIteratorKey <- IteratorKey -> m (StrictTVar m IteratorKey)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (Word -> IteratorKey
IteratorKey Word
0)
      StrictTVar m FollowerKey
varNextFollowerKey <- FollowerKey -> m (StrictTVar m FollowerKey)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (Word -> FollowerKey
FollowerKey   Word
0)
      StrictMVar m ()
varCopyLock        <- () -> m (StrictMVar m ())
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictMVar m a)
newMVar  ()
      StrictTVar m (m ())
varKillBgThreads   <- m () -> m (StrictTVar m (m ()))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (m () -> m (StrictTVar m (m ())))
-> m () -> m (StrictTVar m (m ()))
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      BlocksToAdd m blk
blocksToAdd        <- Word -> m (BlocksToAdd m blk)
forall (m :: * -> *) blk. IOLike m => Word -> m (BlocksToAdd m blk)
newBlocksToAdd (ChainDbArgs Identity m blk -> Word
forall (f :: * -> *) (m :: * -> *) blk. ChainDbArgs f m blk -> Word
Args.cdbBlocksToAddSize ChainDbArgs Identity m blk
args)

      let env :: ChainDbEnv m blk
env = CDB :: forall (m :: * -> *) blk.
ImmutableDB m blk
-> VolatileDB m blk
-> LgrDB m blk
-> StrictTVar m (AnchoredFragment (Header blk))
-> StrictTVar m (TentativeState blk)
-> StrictTVar m (StrictMaybe (Header blk))
-> StrictTVar m (Map IteratorKey (m ()))
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
-> TopLevelConfig blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> StrictTVar m IteratorKey
-> StrictTVar m FollowerKey
-> StrictMVar m ()
-> Tracer m (TraceEvent blk)
-> Tracer m (LedgerDB' blk)
-> ResourceRegistry m
-> DiffTime
-> DiffTime
-> StrictTVar m (m ())
-> ChunkInfo
-> (blk -> Bool)
-> CheckInFuture m blk
-> BlocksToAdd m blk
-> StrictTVar m (FutureBlocks m blk)
-> ChainDbEnv m blk
CDB { cdbImmutableDB :: ImmutableDB m blk
cdbImmutableDB     = ImmutableDB m blk
immutableDB
                    , cdbVolatileDB :: VolatileDB m blk
cdbVolatileDB      = VolatileDB m blk
volatileDB
                    , cdbLgrDB :: LgrDB m blk
cdbLgrDB           = LgrDB m blk
lgrDB
                    , cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbChain           = StrictTVar m (AnchoredFragment (Header blk))
varChain
                    , cdbTentativeState :: StrictTVar m (TentativeState blk)
cdbTentativeState  = StrictTVar m (TentativeState blk)
varTentativeState
                    , cdbTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
cdbTentativeHeader = StrictTVar m (StrictMaybe (Header blk))
varTentativeHeader
                    , cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbIterators       = StrictTVar m (Map IteratorKey (m ()))
varIterators
                    , cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers       = StrictTVar m (Map FollowerKey (FollowerHandle m blk))
varFollowers
                    , cdbTopLevelConfig :: TopLevelConfig blk
cdbTopLevelConfig  = TopLevelConfig blk
cfg
                    , cdbInvalid :: StrictTVar
  m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
cdbInvalid         = StrictTVar
  m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
varInvalid
                    , cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbNextIteratorKey = StrictTVar m IteratorKey
varNextIteratorKey
                    , cdbNextFollowerKey :: StrictTVar m FollowerKey
cdbNextFollowerKey = StrictTVar m FollowerKey
varNextFollowerKey
                    , cdbCopyLock :: StrictMVar m ()
cdbCopyLock        = StrictMVar m ()
varCopyLock
                    , cdbTracer :: Tracer m (TraceEvent blk)
cdbTracer          = Tracer m (TraceEvent blk)
tracer
                    , cdbTraceLedger :: Tracer m (LedgerDB' blk)
cdbTraceLedger     = ChainDbArgs Identity m blk -> Tracer m (LedgerDB' blk)
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> Tracer m (LedgerDB' blk)
Args.cdbTraceLedger ChainDbArgs Identity m blk
args
                    , cdbRegistry :: ResourceRegistry m
cdbRegistry        = ChainDbArgs Identity m blk -> HKD Identity (ResourceRegistry m)
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> HKD f (ResourceRegistry m)
Args.cdbRegistry ChainDbArgs Identity m blk
args
                    , cdbGcDelay :: DiffTime
cdbGcDelay         = ChainDbArgs Identity m blk -> DiffTime
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> DiffTime
Args.cdbGcDelay ChainDbArgs Identity m blk
args
                    , cdbGcInterval :: DiffTime
cdbGcInterval      = ChainDbArgs Identity m blk -> DiffTime
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> DiffTime
Args.cdbGcInterval ChainDbArgs Identity m blk
args
                    , cdbKillBgThreads :: StrictTVar m (m ())
cdbKillBgThreads   = StrictTVar m (m ())
varKillBgThreads
                    , cdbChunkInfo :: ChunkInfo
cdbChunkInfo       = ChainDbArgs Identity m blk -> HKD Identity ChunkInfo
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> HKD f ChunkInfo
Args.cdbChunkInfo ChainDbArgs Identity m blk
args
                    , cdbCheckIntegrity :: blk -> Bool
cdbCheckIntegrity  = ChainDbArgs Identity m blk -> HKD Identity (blk -> Bool)
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> HKD f (blk -> Bool)
Args.cdbCheckIntegrity ChainDbArgs Identity m blk
args
                    , cdbCheckInFuture :: CheckInFuture m blk
cdbCheckInFuture   = ChainDbArgs Identity m blk -> HKD Identity (CheckInFuture m blk)
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> HKD f (CheckInFuture m blk)
Args.cdbCheckInFuture ChainDbArgs Identity m blk
args
                    , cdbBlocksToAdd :: BlocksToAdd m blk
cdbBlocksToAdd     = BlocksToAdd m blk
blocksToAdd
                    , cdbFutureBlocks :: StrictTVar
  m (Map (HeaderHash blk) (Header blk, InvalidBlockPunishment m))
cdbFutureBlocks    = StrictTVar
  m (Map (HeaderHash blk) (Header blk, InvalidBlockPunishment m))
varFutureBlocks
                    }
      ChainDbHandle m blk
h <- (StrictTVar m (ChainDbState m blk) -> ChainDbHandle m blk)
-> m (StrictTVar m (ChainDbState m blk)) -> m (ChainDbHandle m blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StrictTVar m (ChainDbState m blk) -> ChainDbHandle m blk
forall (m :: * -> *) blk.
StrictTVar m (ChainDbState m blk) -> ChainDbHandle m blk
CDBHandle (m (StrictTVar m (ChainDbState m blk)) -> m (ChainDbHandle m blk))
-> m (StrictTVar m (ChainDbState m blk)) -> m (ChainDbHandle m blk)
forall a b. (a -> b) -> a -> b
$ ChainDbState m blk -> m (StrictTVar m (ChainDbState m blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (ChainDbState m blk -> m (StrictTVar m (ChainDbState m blk)))
-> ChainDbState m blk -> m (StrictTVar m (ChainDbState m blk))
forall a b. (a -> b) -> a -> b
$ ChainDbEnv m blk -> ChainDbState m blk
forall (m :: * -> *) blk. ChainDbEnv m blk -> ChainDbState m blk
ChainDbOpen ChainDbEnv m blk
env
      let chainDB :: ChainDB m blk
chainDB = ChainDB :: forall (m :: * -> *) blk.
(InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk))
-> STM m (AnchoredFragment (Header blk))
-> STM m (LedgerDB (ExtLedgerState blk))
-> m (Maybe blk)
-> m (Maybe (Header blk))
-> STM m (Point blk)
-> (forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b))
-> STM m (Point blk -> Bool)
-> STM m (RealPoint blk -> Maybe Bool)
-> STM m MaxSlotNo
-> (forall b.
    ResourceRegistry m
    -> BlockComponent blk b
    -> StreamFrom blk
    -> StreamTo blk
    -> m (Either (UnknownRange blk) (Iterator m blk b)))
-> (forall b.
    ResourceRegistry m
    -> ChainType -> BlockComponent blk b -> m (Follower m blk b))
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (InvalidBlockReason blk)))
-> m ()
-> STM m Bool
-> ChainDB m blk
API.ChainDB
            { addBlockAsync :: InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
addBlockAsync         = ChainDbHandle m blk
-> (ChainDbEnv m blk
    -> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk))
-> InvalidBlockPunishment m
-> blk
-> m (AddBlockPromise m blk)
forall (m :: * -> *) blk a b r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk
-> (ChainDbEnv m blk -> a -> b -> m r) -> a -> b -> m r
getEnv2    ChainDbHandle m blk
h ChainDbEnv m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
ChainDbEnv m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
ChainSel.addBlockAsync
            , getCurrentChain :: STM m (AnchoredFragment (Header blk))
getCurrentChain       = ChainDbHandle m blk
-> (ChainDbEnv m blk -> STM m (AnchoredFragment (Header blk)))
-> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> STM m r) -> STM m r
getEnvSTM  ChainDbHandle m blk
h ChainDbEnv m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk),
 ConsensusProtocol (BlockProtocol blk)) =>
ChainDbEnv m blk -> STM m (AnchoredFragment (Header blk))
Query.getCurrentChain
            , getLedgerDB :: STM m (LedgerDB' blk)
getLedgerDB           = ChainDbHandle m blk
-> (ChainDbEnv m blk -> STM m (LedgerDB' blk))
-> STM m (LedgerDB' blk)
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> STM m r) -> STM m r
getEnvSTM  ChainDbHandle m blk
h ChainDbEnv m blk -> STM m (LedgerDB' blk)
forall (m :: * -> *) blk.
IOLike m =>
ChainDbEnv m blk -> STM m (LedgerDB' blk)
Query.getLedgerDB
            , getTipBlock :: m (Maybe blk)
getTipBlock           = ChainDbHandle m blk
-> (ChainDbEnv m blk -> m (Maybe blk)) -> m (Maybe blk)
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> m r) -> m r
getEnv     ChainDbHandle m blk
h ChainDbEnv m blk -> m (Maybe blk)
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, HasHeader (Header blk)) =>
ChainDbEnv m blk -> m (Maybe blk)
Query.getTipBlock
            , getTipHeader :: m (Maybe (Header blk))
getTipHeader          = ChainDbHandle m blk
-> (ChainDbEnv m blk -> m (Maybe (Header blk)))
-> m (Maybe (Header blk))
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> m r) -> m r
getEnv     ChainDbHandle m blk
h ChainDbEnv m blk -> m (Maybe (Header blk))
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, HasHeader (Header blk)) =>
ChainDbEnv m blk -> m (Maybe (Header blk))
Query.getTipHeader
            , getTipPoint :: STM m (Point blk)
getTipPoint           = ChainDbHandle m blk
-> (ChainDbEnv m blk -> STM m (Point blk)) -> STM m (Point blk)
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> STM m r) -> STM m r
getEnvSTM  ChainDbHandle m blk
h ChainDbEnv m blk -> STM m (Point blk)
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk)) =>
ChainDbEnv m blk -> STM m (Point blk)
Query.getTipPoint
            , getBlockComponent :: forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b)
getBlockComponent     = ChainDbHandle m blk
-> (ChainDbEnv m blk
    -> BlockComponent blk b -> RealPoint blk -> m (Maybe b))
-> BlockComponent blk b
-> RealPoint blk
-> m (Maybe b)
forall (m :: * -> *) blk a b r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk
-> (ChainDbEnv m blk -> a -> b -> m r) -> a -> b -> m r
getEnv2    ChainDbHandle m blk
h ChainDbEnv m blk
-> BlockComponent blk b -> RealPoint blk -> m (Maybe b)
forall (m :: * -> *) blk b.
IOLike m =>
ChainDbEnv m blk
-> BlockComponent blk b -> RealPoint blk -> m (Maybe b)
Query.getBlockComponent
            , getIsFetched :: STM m (Point blk -> Bool)
getIsFetched          = ChainDbHandle m blk
-> (ChainDbEnv m blk -> STM m (Point blk -> Bool))
-> STM m (Point blk -> Bool)
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> STM m r) -> STM m r
getEnvSTM  ChainDbHandle m blk
h ChainDbEnv m blk -> STM m (Point blk -> Bool)
forall (m :: * -> *) blk.
IOLike m =>
ChainDbEnv m blk -> STM m (Point blk -> Bool)
Query.getIsFetched
            , getIsValid :: STM m (RealPoint blk -> Maybe Bool)
getIsValid            = ChainDbHandle m blk
-> (ChainDbEnv m blk -> STM m (RealPoint blk -> Maybe Bool))
-> STM m (RealPoint blk -> Maybe Bool)
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> STM m r) -> STM m r
getEnvSTM  ChainDbHandle m blk
h ChainDbEnv m blk -> STM m (RealPoint blk -> Maybe Bool)
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
ChainDbEnv m blk -> STM m (RealPoint blk -> Maybe Bool)
Query.getIsValid
            , getMaxSlotNo :: STM m MaxSlotNo
getMaxSlotNo          = ChainDbHandle m blk
-> (ChainDbEnv m blk -> STM m MaxSlotNo) -> STM m MaxSlotNo
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> STM m r) -> STM m r
getEnvSTM  ChainDbHandle m blk
h ChainDbEnv m blk -> STM m MaxSlotNo
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk)) =>
ChainDbEnv m blk -> STM m MaxSlotNo
Query.getMaxSlotNo
            , stream :: forall b.
ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk b))
stream                = ChainDbHandle m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk b))
forall (m :: * -> *) blk b.
(IOLike m, HasHeader blk, HasCallStack) =>
ChainDbHandle m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk b))
Iterator.stream  ChainDbHandle m blk
h
            , newFollower :: forall b.
ResourceRegistry m
-> ChainType -> BlockComponent blk b -> m (Follower m blk b)
newFollower           = ChainDbHandle m blk
-> ResourceRegistry m
-> ChainType
-> BlockComponent blk b
-> m (Follower m blk b)
forall (m :: * -> *) blk b.
(IOLike m, HasHeader blk, GetHeader blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
ChainDbHandle m blk
-> ResourceRegistry m
-> ChainType
-> BlockComponent blk b
-> m (Follower m blk b)
Follower.newFollower ChainDbHandle m blk
h
            , getIsInvalidBlock :: STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (InvalidBlockReason blk)))
getIsInvalidBlock     = ChainDbHandle m blk
-> (ChainDbEnv m blk
    -> STM
         m
         (WithFingerprint
            (HeaderHash blk -> Maybe (InvalidBlockReason blk))))
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (InvalidBlockReason blk)))
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> STM m r) -> STM m r
getEnvSTM  ChainDbHandle m blk
h ChainDbEnv m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (InvalidBlockReason blk)))
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
ChainDbEnv m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (InvalidBlockReason blk)))
Query.getIsInvalidBlock
            , closeDB :: m ()
closeDB               = ChainDbHandle m blk -> m ()
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk), HasCallStack) =>
ChainDbHandle m blk -> m ()
closeDB ChainDbHandle m blk
h
            , isOpen :: STM m Bool
isOpen                = ChainDbHandle m blk -> STM m Bool
forall (m :: * -> *) blk.
IOLike m =>
ChainDbHandle m blk -> STM m Bool
isOpen  ChainDbHandle m blk
h
            }
          testing :: Internal m blk
testing = Internal :: forall (m :: * -> *) blk.
m (WithOrigin SlotNo)
-> (SlotNo -> m ())
-> m ()
-> m Void
-> StrictTVar m (m ())
-> Internal m blk
Internal
            { intCopyToImmutableDB :: m (WithOrigin SlotNo)
intCopyToImmutableDB       = ChainDbHandle m blk
-> (ChainDbEnv m blk -> m (WithOrigin SlotNo))
-> m (WithOrigin SlotNo)
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> m r) -> m r
getEnv  ChainDbHandle m blk
h ChainDbEnv m blk -> m (WithOrigin SlotNo)
forall (m :: * -> *) blk.
(IOLike m, ConsensusProtocol (BlockProtocol blk), HasHeader blk,
 GetHeader blk, HasCallStack) =>
ChainDbEnv m blk -> m (WithOrigin SlotNo)
Background.copyToImmutableDB
            , intGarbageCollect :: SlotNo -> m ()
intGarbageCollect          = ChainDbHandle m blk
-> (ChainDbEnv m blk -> SlotNo -> m ()) -> SlotNo -> m ()
forall (m :: * -> *) blk a r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> a -> m r) -> a -> m r
getEnv1 ChainDbHandle m blk
h ChainDbEnv m blk -> SlotNo -> m ()
forall (m :: * -> *) blk.
IOLike m =>
ChainDbEnv m blk -> SlotNo -> m ()
Background.garbageCollect
            , intUpdateLedgerSnapshots :: m ()
intUpdateLedgerSnapshots   = ChainDbHandle m blk -> (ChainDbEnv m blk -> m ()) -> m ()
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> m r) -> m r
getEnv  ChainDbHandle m blk
h ChainDbEnv m blk -> m ()
forall (m :: * -> *) blk.
(IOLike m, LgrDbSerialiseConstraints blk, HasHeader blk,
 IsLedger (LedgerState blk)) =>
ChainDbEnv m blk -> m ()
Background.updateLedgerSnapshots
            , intAddBlockRunner :: m Void
intAddBlockRunner          = ChainDbHandle m blk -> (ChainDbEnv m blk -> m Void) -> m Void
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> m r) -> m r
getEnv  ChainDbHandle m blk
h ChainDbEnv m blk -> m Void
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasHardForkHistory blk, HasCallStack) =>
ChainDbEnv m blk -> m Void
Background.addBlockRunner
            , intKillBgThreads :: StrictTVar m (m ())
intKillBgThreads           = StrictTVar m (m ())
varKillBgThreads
            }

      Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ TraceOpenEvent blk -> TraceEvent blk
forall blk. TraceOpenEvent blk -> TraceEvent blk
TraceOpenEvent (TraceOpenEvent blk -> TraceEvent blk)
-> TraceOpenEvent blk -> TraceEvent blk
forall a b. (a -> b) -> a -> b
$ Point blk -> Point blk -> TraceOpenEvent blk
forall blk. Point blk -> Point blk -> TraceOpenEvent blk
OpenedDB
        (Point (Header blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment (Header blk)
chain)
        (Point (Header blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint   AnchoredFragment (Header blk)
chain)

      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
launchBgTasks (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ChainDbEnv m blk -> Word64 -> m ()
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasHardForkHistory blk, LgrDbSerialiseConstraints blk) =>
ChainDbEnv m blk -> Word64 -> m ()
Background.launchBgTasks ChainDbEnv m blk
env Word64
replayed

      (ChainDB m blk, Internal m blk, ChainDbEnv m blk)
-> m (ChainDB m blk, Internal m blk, ChainDbEnv m blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (ChainDB m blk
chainDB, Internal m blk
forall blk. Internal m blk
testing, ChainDbEnv m blk
env)

    (ResourceKey m, ChainDB m blk)
_ <- m (ResourceKey m, ChainDB m blk)
-> WithTempRegistry
     (ChainDbEnv m blk) m (ResourceKey m, ChainDB m blk)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ResourceKey m, ChainDB m blk)
 -> WithTempRegistry
      (ChainDbEnv m blk) m (ResourceKey m, ChainDB m blk))
-> m (ResourceKey m, ChainDB m blk)
-> WithTempRegistry
     (ChainDbEnv m blk) m (ResourceKey m, ChainDB m blk)
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m
-> (ResourceId -> m (ChainDB m blk))
-> (ChainDB m blk -> m ())
-> m (ResourceKey m, ChainDB m blk)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
ResourceRegistry m
-> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a)
allocate (ChainDbArgs Identity m blk -> HKD Identity (ResourceRegistry m)
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> HKD f (ResourceRegistry m)
Args.cdbRegistry ChainDbArgs Identity m blk
args) (\ResourceId
_ -> ChainDB m blk -> m (ChainDB m blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (ChainDB m blk -> m (ChainDB m blk))
-> ChainDB m blk -> m (ChainDB m blk)
forall a b. (a -> b) -> a -> b
$ ChainDB m blk
chainDB) ChainDB m blk -> m ()
forall (m :: * -> *) blk. ChainDB m blk -> m ()
API.closeDB

    ((ChainDB m blk, Internal m blk), ChainDbEnv m blk)
-> WithTempRegistry
     (ChainDbEnv m blk)
     m
     ((ChainDB m blk, Internal m blk), ChainDbEnv m blk)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ChainDB m blk
chainDB, Internal m blk
testing), ChainDbEnv m blk
env)
  where
    tracer :: Tracer m (TraceEvent blk)
tracer = ChainDbArgs Identity m blk -> Tracer m (TraceEvent blk)
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> Tracer m (TraceEvent blk)
Args.cdbTracer ChainDbArgs Identity m blk
args
    (ImmutableDbArgs Identity m blk
argsImmutableDb, VolatileDbArgs Identity m blk
argsVolatileDb, LgrDbArgs Identity m blk
argsLgrDb, ChainDbSpecificArgs Identity m blk
_) = ChainDbArgs Identity m blk
-> (ImmutableDbArgs Identity m blk, VolatileDbArgs Identity m blk,
    LgrDbArgs Identity m blk, ChainDbSpecificArgs Identity m blk)
forall (m :: * -> *) blk (f :: * -> *).
MapHKD f =>
ChainDbArgs f m blk
-> (ImmutableDbArgs f m blk, VolatileDbArgs f m blk,
    LgrDbArgs f m blk, ChainDbSpecificArgs f m blk)
Args.fromChainDbArgs ChainDbArgs Identity m blk
args

-- | We use 'runInnerWithTempRegistry' for the component databases.
innerOpenCont ::
     IOLike m
  => (innerDB -> m ())
  -> WithTempRegistry st m (innerDB, st)
  -> WithTempRegistry (ChainDbEnv m blk) m innerDB
innerOpenCont :: (innerDB -> m ())
-> WithTempRegistry st m (innerDB, st)
-> WithTempRegistry (ChainDbEnv m blk) m innerDB
innerOpenCont innerDB -> m ()
closer WithTempRegistry st m (innerDB, st)
m =
  WithTempRegistry st m (innerDB, st, innerDB)
-> (innerDB -> m Bool)
-> (ChainDbEnv m blk -> innerDB -> Bool)
-> WithTempRegistry (ChainDbEnv m blk) m innerDB
forall innerSt st (m :: * -> *) res a.
IOLike m =>
WithTempRegistry innerSt m (a, innerSt, res)
-> (res -> m Bool)
-> (st -> res -> Bool)
-> WithTempRegistry st m a
runInnerWithTempRegistry
    (((innerDB, st) -> (innerDB, st, innerDB))
-> WithTempRegistry st m (innerDB, st)
-> WithTempRegistry st m (innerDB, st, innerDB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(innerDB
innerDB, st
st) -> (innerDB
innerDB, st
st, innerDB
innerDB)) WithTempRegistry st m (innerDB, st)
m)
    ((Bool
True Bool -> m () -> m Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (m () -> m Bool) -> (innerDB -> m ()) -> innerDB -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. innerDB -> m ()
closer)
    (\ChainDbEnv m blk
_env innerDB
_innerDB -> Bool
True)
      -- This check is degenerate because handles in @_env@ and the
      -- @_innerDB@ handle do not support an equality check; all of the
      -- identifying data is only in the handle's closure, not
      -- accessible because of our intentional encapsulation choices.

isOpen :: IOLike m => ChainDbHandle m blk -> STM m Bool
isOpen :: ChainDbHandle m blk -> STM m Bool
isOpen (CDBHandle StrictTVar m (ChainDbState m blk)
varState) = StrictTVar m (ChainDbState m blk) -> STM m (ChainDbState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainDbState m blk)
varState STM m (ChainDbState m blk)
-> (ChainDbState m blk -> Bool) -> STM m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    ChainDbState m blk
ChainDbClosed    -> Bool
False
    ChainDbOpen ChainDbEnv m blk
_env -> Bool
True

closeDB
  :: forall m blk.
     ( IOLike m
     , HasHeader (Header blk)
     , HasCallStack
     )
  => ChainDbHandle m blk -> m ()
closeDB :: ChainDbHandle m blk -> m ()
closeDB (CDBHandle StrictTVar m (ChainDbState m blk)
varState) = do
    Maybe (ChainDbEnv m blk)
mbOpenEnv <- STM m (Maybe (ChainDbEnv m blk)) -> m (Maybe (ChainDbEnv m blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (ChainDbEnv m blk)) -> m (Maybe (ChainDbEnv m blk)))
-> STM m (Maybe (ChainDbEnv m blk)) -> m (Maybe (ChainDbEnv m blk))
forall a b. (a -> b) -> a -> b
$ StrictTVar m (ChainDbState m blk) -> STM m (ChainDbState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainDbState m blk)
varState STM m (ChainDbState m blk)
-> (ChainDbState m blk -> STM m (Maybe (ChainDbEnv m blk)))
-> STM m (Maybe (ChainDbEnv m blk))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- Idempotent
      ChainDbState m blk
ChainDbClosed   -> Maybe (ChainDbEnv m blk) -> STM m (Maybe (ChainDbEnv m blk))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ChainDbEnv m blk)
forall a. Maybe a
Nothing
      ChainDbOpen ChainDbEnv m blk
env -> do
        StrictTVar m (ChainDbState m blk) -> ChainDbState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ChainDbState m blk)
varState ChainDbState m blk
forall (m :: * -> *) blk. ChainDbState m blk
ChainDbClosed
        Maybe (ChainDbEnv m blk) -> STM m (Maybe (ChainDbEnv m blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ChainDbEnv m blk) -> STM m (Maybe (ChainDbEnv m blk)))
-> Maybe (ChainDbEnv m blk) -> STM m (Maybe (ChainDbEnv m blk))
forall a b. (a -> b) -> a -> b
$ ChainDbEnv m blk -> Maybe (ChainDbEnv m blk)
forall a. a -> Maybe a
Just ChainDbEnv m blk
env

    -- Only when the ChainDB was open
    Maybe (ChainDbEnv m blk) -> (ChainDbEnv m blk -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (ChainDbEnv m blk)
mbOpenEnv ((ChainDbEnv m blk -> m ()) -> m ())
-> (ChainDbEnv m blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \cdb :: ChainDbEnv m blk
cdb@CDB{Tracer m (LedgerDB' blk)
Tracer m (TraceEvent blk)
DiffTime
StrictTVar m (m ())
StrictTVar m (FutureBlocks m blk)
StrictTVar m (Map FollowerKey (FollowerHandle m blk))
StrictTVar m (Map IteratorKey (m ()))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (StrictMaybe (Header blk))
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m (TentativeState blk)
StrictTVar m FollowerKey
StrictTVar m IteratorKey
TopLevelConfig blk
StrictMVar m ()
VolatileDB m blk
ChunkInfo
ResourceRegistry m
ImmutableDB m blk
CheckInFuture m blk
LgrDB m blk
BlocksToAdd m blk
blk -> Bool
cdbFutureBlocks :: StrictTVar m (FutureBlocks m blk)
cdbBlocksToAdd :: BlocksToAdd m blk
cdbCheckInFuture :: CheckInFuture m blk
cdbCheckIntegrity :: blk -> Bool
cdbChunkInfo :: ChunkInfo
cdbKillBgThreads :: StrictTVar m (m ())
cdbGcInterval :: DiffTime
cdbGcDelay :: DiffTime
cdbRegistry :: ResourceRegistry m
cdbTraceLedger :: Tracer m (LedgerDB' blk)
cdbTracer :: Tracer m (TraceEvent blk)
cdbCopyLock :: StrictMVar m ()
cdbNextFollowerKey :: StrictTVar m FollowerKey
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
cdbTentativeState :: StrictTVar m (TentativeState blk)
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: LgrDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbImmutableDB :: ImmutableDB m blk
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks m blk)
cdbBlocksToAdd :: forall (m :: * -> *) blk. ChainDbEnv m blk -> BlocksToAdd m blk
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbCheckIntegrity :: forall (m :: * -> *) blk. ChainDbEnv m blk -> blk -> Bool
cdbChunkInfo :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChunkInfo
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbTraceLedger :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (LedgerDB' blk)
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
cdbCopyLock :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictMVar m ()
cdbNextFollowerKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m FollowerKey
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbTentativeHeader :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (StrictMaybe (Header blk))
cdbTentativeState :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (TentativeState blk)
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
..} -> do

      ChainDbEnv m blk -> m ()
forall (m :: * -> *) blk. IOLike m => ChainDbEnv m blk -> m ()
Follower.closeAllFollowers ChainDbEnv m blk
cdb
      ChainDbEnv m blk -> m ()
forall (m :: * -> *) blk. IOLike m => ChainDbEnv m blk -> m ()
Iterator.closeAllIterators ChainDbEnv m blk
cdb

      m ()
killBgThreads <- STM m (m ()) -> m (m ())
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m ()) -> m (m ())) -> STM m (m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ StrictTVar m (m ()) -> STM m (m ())
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (m ())
cdbKillBgThreads
      m ()
killBgThreads

      ImmutableDB m blk -> m ()
forall (m :: * -> *) blk. HasCallStack => ImmutableDB m blk -> m ()
ImmutableDB.closeDB ImmutableDB m blk
cdbImmutableDB
      VolatileDB m blk -> HasCallStack => m ()
forall (m :: * -> *) blk. VolatileDB m blk -> HasCallStack => m ()
VolatileDB.closeDB VolatileDB m blk
cdbVolatileDB

      AnchoredFragment (Header blk)
chain <- STM m (AnchoredFragment (Header blk))
-> m (AnchoredFragment (Header blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (AnchoredFragment (Header blk))
 -> m (AnchoredFragment (Header blk)))
-> STM m (AnchoredFragment (Header blk))
-> m (AnchoredFragment (Header blk))
forall a b. (a -> b) -> a -> b
$ StrictTVar m (AnchoredFragment (Header blk))
-> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (AnchoredFragment (Header blk))
cdbChain

      Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
cdbTracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ TraceOpenEvent blk -> TraceEvent blk
forall blk. TraceOpenEvent blk -> TraceEvent blk
TraceOpenEvent (TraceOpenEvent blk -> TraceEvent blk)
-> TraceOpenEvent blk -> TraceEvent blk
forall a b. (a -> b) -> a -> b
$ Point blk -> Point blk -> TraceOpenEvent blk
forall blk. Point blk -> Point blk -> TraceOpenEvent blk
ClosedDB
        (Point (Header blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment (Header blk)
chain)
        (Point (Header blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
chain)

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Lift 'chunkIndexOfSlot' to 'Point'
--
-- Returns 'firstChunkNo' in case of 'GenesisPoint'.
chunkIndexOfPoint :: ImmutableDB.ChunkInfo -> Point blk -> ImmutableDB.ChunkNo
chunkIndexOfPoint :: ChunkInfo -> Point blk -> ChunkNo
chunkIndexOfPoint ChunkInfo
chunkInfo = \case
    Point blk
GenesisPoint      -> ChunkNo
ImmutableDB.firstChunkNo
    BlockPoint SlotNo
slot HeaderHash blk
_ -> ChunkInfo -> SlotNo -> ChunkNo
ImmutableDB.chunkIndexOfSlot ChunkInfo
chunkInfo SlotNo
slot