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

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

import           Control.Monad (when)
import           Control.Tracer
import           Data.Functor ((<&>))
import           Data.Functor.Identity (Identity)
import qualified Data.Map.Strict as Map
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.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.Iterator as Iterator
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LgrDB
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Query as Query
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Reader as Reader
import           Ouroboros.Consensus.Storage.ChainDB.Impl.Types
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB

{-------------------------------------------------------------------------------
  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 = do
    ImmutableDB m blk
immutableDB <- ImmutableDbArgs Identity m blk -> m (ImmutableDB m blk)
forall (m :: * -> *) blk.
(IOLike m, GetPrevHash blk, ConvertRawHash blk,
 ImmutableDbSerialiseConstraints blk, HasCallStack) =>
ImmutableDbArgs Identity m blk -> m (ImmutableDB m blk)
ImmutableDB.openDB ImmutableDbArgs Identity m blk
argsImmutableDb
    Point blk
immutableDbTipPoint <- 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
    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

    VolatileDB m blk
volatileDB <- VolatileDbArgs Identity m blk -> m (VolatileDB m blk)
forall (m :: * -> *) blk.
(HasCallStack, IOLike m, HasHeader blk, GetPrevHash blk,
 VolatileDbSerialiseConstraints blk) =>
VolatileDbArgs Identity m blk -> m (VolatileDB m blk)
VolatileDB.openDB VolatileDbArgs Identity m blk
argsVolatileDb
    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 (TraceReplayEvent blk ())
lgrReplayTracer =
          Point blk
-> Tracer m (TraceLedgerReplayEvent blk)
-> Tracer m (TraceReplayEvent blk ())
forall blk (m :: * -> *).
Point blk
-> Tracer m (TraceLedgerReplayEvent blk)
-> Tracer m (TraceReplayEvent blk ())
LgrDB.decorateReplayTracer
            Point blk
immutableDbTipPoint
            ((TraceLedgerReplayEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk)
-> Tracer m (TraceLedgerReplayEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap TraceLedgerReplayEvent blk -> TraceEvent blk
forall blk. TraceLedgerReplayEvent blk -> TraceEvent blk
TraceLedgerReplayEvent Tracer m (TraceEvent blk)
tracer)
    (LgrDB m blk
lgrDB, Word64
replayed) <- LgrDbArgs Identity m blk
-> Tracer m (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 (TraceReplayEvent blk ())
-> ImmutableDB m blk
-> (RealPoint blk -> m blk)
-> m (LgrDB m blk, Word64)
LgrDB.openDB LgrDbArgs Identity m blk
argsLgrDb
                            Tracer m (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))
varFutureBlocks <- Map (HeaderHash blk) (Header blk)
-> m (StrictTVar m (Map (HeaderHash blk) (Header blk)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Map (HeaderHash blk) (Header blk)
forall k a. Map k a
Map.empty


    ChainAndLedger blk
chainAndLedger <- ImmutableDB m blk
-> VolatileDB m blk
-> LgrDB m blk
-> Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> StrictTVar
     m (WithFingerprint (Map (HeaderHash blk) (InvalidBlockInfo blk)))
-> StrictTVar m (Map (HeaderHash blk) (Header blk))
-> CheckInFuture m blk
-> m (ChainAndLedger blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
ImmutableDB m blk
-> VolatileDB m blk
-> LgrDB m blk
-> Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> StrictTVar m (FutureBlocks blk)
-> CheckInFuture m blk
-> m (ChainAndLedger blk)
ChainSel.initialChainSelection
                        ImmutableDB m blk
immutableDB
                        VolatileDB m blk
volatileDB
                        LgrDB m blk
lgrDB
                        Tracer m (TraceEvent blk)
tracer
                        (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))
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)

    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 (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 ReaderKey (ReaderHandle m blk))
varReaders         <- Map ReaderKey (ReaderHandle m blk)
-> m (StrictTVar m (Map ReaderKey (ReaderHandle m blk)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Map ReaderKey (ReaderHandle 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 ReaderKey
varNextReaderKey   <- ReaderKey -> m (StrictTVar m ReaderKey)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (Word -> ReaderKey
ReaderKey   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 (Map IteratorKey (m ()))
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
-> TopLevelConfig blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
-> StrictTVar m IteratorKey
-> StrictTVar m ReaderKey
-> 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 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
                  , cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbIterators       = StrictTVar m (Map IteratorKey (m ()))
varIterators
                  , cdbReaders :: StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbReaders         = StrictTVar m (Map ReaderKey (ReaderHandle m blk))
varReaders
                  , 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
                  , cdbNextReaderKey :: StrictTVar m ReaderKey
cdbNextReaderKey   = StrictTVar m ReaderKey
varNextReaderKey
                  , 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))
cdbFutureBlocks    = StrictTVar m (Map (HeaderHash blk) (Header blk))
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.
(blk -> m (AddBlockPromise m blk))
-> STM m (AnchoredFragment (Header blk))
-> STM m (ExtLedgerState blk)
-> (Point blk -> STM m (Maybe (ExtLedgerState blk)))
-> STM m (HeaderStateHistory 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 -> BlockComponent blk b -> m (Reader m blk b))
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (InvalidBlockReason blk)))
-> m ()
-> STM m Bool
-> ChainDB m blk
API.ChainDB
          { addBlockAsync :: blk -> m (AddBlockPromise m blk)
addBlockAsync         = ChainDbHandle m blk
-> (ChainDbEnv m blk -> blk -> m (AddBlockPromise m blk))
-> blk
-> m (AddBlockPromise m blk)
forall (m :: * -> *) blk a r.
(IOLike m, HasCallStack) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> a -> m r) -> a -> m r
getEnv1    ChainDbHandle m blk
h ChainDbEnv m blk -> blk -> m (AddBlockPromise m blk)
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
ChainDbEnv m blk -> 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) =>
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
          , getCurrentLedger :: STM m (ExtLedgerState blk)
getCurrentLedger      = ChainDbHandle m blk
-> (ChainDbEnv m blk -> STM m (ExtLedgerState blk))
-> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> STM m r) -> STM m r
getEnvSTM  ChainDbHandle m blk
h ChainDbEnv m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
IOLike m =>
ChainDbEnv m blk -> STM m (ExtLedgerState blk)
Query.getCurrentLedger
          , getPastLedger :: Point blk -> STM m (Maybe (ExtLedgerState blk))
getPastLedger         = ChainDbHandle m blk
-> (ChainDbEnv m blk
    -> Point blk -> STM m (Maybe (ExtLedgerState blk)))
-> Point blk
-> STM m (Maybe (ExtLedgerState blk))
forall (m :: * -> *) blk a r.
(IOLike m, HasCallStack) =>
ChainDbHandle m blk
-> (ChainDbEnv m blk -> a -> STM m r) -> a -> STM m r
getEnvSTM1 ChainDbHandle m blk
h ChainDbEnv m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
forall blk (m :: * -> *).
(HasHeader blk, IOLike m) =>
ChainDbEnv m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
Query.getPastLedger
          , getHeaderStateHistory :: STM m (HeaderStateHistory blk)
getHeaderStateHistory = ChainDbHandle m blk
-> (ChainDbEnv m blk -> STM m (HeaderStateHistory blk))
-> STM m (HeaderStateHistory blk)
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> STM m r) -> STM m r
getEnvSTM  ChainDbHandle m blk
h ChainDbEnv m blk -> STM m (HeaderStateHistory blk)
forall (m :: * -> *) blk.
IOLike m =>
ChainDbEnv m blk -> STM m (HeaderStateHistory blk)
Query.getHeaderStateHistory
          , getTipBlock :: m (Maybe blk)
getTipBlock           = ChainDbHandle m blk
-> (ChainDbEnv m blk -> m (Maybe blk)) -> m (Maybe blk)
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack) =>
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) =>
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) =>
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) =>
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) =>
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) =>
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) =>
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
          , newReader :: forall b.
ResourceRegistry m -> BlockComponent blk b -> m (Reader m blk b)
newReader             = ChainDbHandle m blk
-> ResourceRegistry m -> BlockComponent blk b -> m (Reader 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 -> BlockComponent blk b -> m (Reader m blk b)
Reader.newReader 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) =>
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) =>
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) =>
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) =>
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) =>
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) =>
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)
-> m (ChainDB m blk, Internal m blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (ChainDB m blk
chainDB, Internal m blk
forall blk. Internal m blk
testing)
  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

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)
StrictTVar m (m ())
StrictTVar m (FutureBlocks blk)
StrictTVar m (Map ReaderKey (ReaderHandle m blk))
StrictTVar m (Map IteratorKey (m ()))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m ReaderKey
StrictTVar m IteratorKey
DiffTime
TopLevelConfig blk
StrictMVar m ()
VolatileDB m blk
ChunkInfo
ResourceRegistry m
ImmutableDB m blk
LgrDB m blk
CheckInFuture m blk
BlocksToAdd m blk
blk -> Bool
cdbFutureBlocks :: StrictTVar m (FutureBlocks 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 ()
cdbNextReaderKey :: StrictTVar m ReaderKey
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbReaders :: StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
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 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 ()
cdbNextReaderKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m ReaderKey
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
cdbReaders :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
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 ()
Reader.closeAllReaders     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