{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

-- | Readers
module Ouroboros.Consensus.Storage.ChainDB.Impl.Reader
  ( newReader
  , switchFork
  , closeAllReaders
  ) where

import           Codec.CBOR.Write (toLazyByteString)
import           Control.Exception (assert)
import           Control.Monad (join)
import           Control.Tracer (contramap, traceWith)
import qualified Data.ByteString.Lazy as Lazy
import           Data.Functor ((<&>))
import           Data.Functor.Identity (Identity (..))
import qualified Data.Map.Strict as Map

import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (ChainUpdate (..))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Util.CallStack
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
import           Ouroboros.Consensus.Util.STM (blockUntilJust)

import           Ouroboros.Consensus.Storage.ChainDB.API (BlockComponent (..),
                     ChainDbError (..), Reader (..), getPoint)
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           Ouroboros.Consensus.Storage.Serialisation

{-------------------------------------------------------------------------------
  Accessing the environment
-------------------------------------------------------------------------------}

-- | Check if the ChainDB is open. If not, throw a 'ClosedDBError'. Next,
-- check whether the reader with the given 'ReaderKey' still exists. If not,
-- throw a 'ClosedReaderError'.
--
-- Otherwise, execute the given function on the 'ChainDbEnv'.
getReader
  :: forall m blk r. (IOLike m, HasCallStack)
  => ChainDbHandle m blk
  -> ReaderKey
  -> (ChainDbEnv m blk -> m r)
  -> m r
getReader :: ChainDbHandle m blk
-> ReaderKey -> (ChainDbEnv m blk -> m r) -> m r
getReader (CDBHandle StrictTVar m (ChainDbState m blk)
varState) ReaderKey
readerKey ChainDbEnv m blk -> m r
f = do
    ChainDbEnv m blk
env <- STM m (ChainDbEnv m blk) -> m (ChainDbEnv m blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ChainDbEnv m blk) -> m (ChainDbEnv m blk))
-> STM m (ChainDbEnv m blk) -> m (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 (ChainDbEnv m blk))
-> STM m (ChainDbEnv m blk)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ChainDbState m blk
ChainDbClosed   -> ChainDbError -> STM m (ChainDbEnv m blk)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ChainDbError -> STM m (ChainDbEnv m blk))
-> ChainDbError -> STM m (ChainDbEnv m blk)
forall a b. (a -> b) -> a -> b
$ PrettyCallStack -> ChainDbError
ClosedDBError PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      ChainDbOpen ChainDbEnv m blk
env -> do
        Bool
readerOpen <- ReaderKey -> Map ReaderKey (ReaderHandle m blk) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member ReaderKey
readerKey (Map ReaderKey (ReaderHandle m blk) -> Bool)
-> STM m (Map ReaderKey (ReaderHandle m blk)) -> STM m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
-> STM m (Map ReaderKey (ReaderHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbReaders ChainDbEnv m blk
env)
        if Bool
readerOpen
          then ChainDbEnv m blk -> STM m (ChainDbEnv m blk)
forall (m :: * -> *) a. Monad m => a -> m a
return ChainDbEnv m blk
env
          else ChainDbError -> STM m (ChainDbEnv m blk)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ChainDbError
ClosedReaderError
    ChainDbEnv m blk -> m r
f ChainDbEnv m blk
env

-- | Variant 'of 'getReader' for functions taking one argument.
getReader1
  :: forall m blk a r. IOLike m
  => ChainDbHandle m blk
  -> ReaderKey
  -> (ChainDbEnv m blk -> a -> m r)
  -> a -> m r
getReader1 :: ChainDbHandle m blk
-> ReaderKey -> (ChainDbEnv m blk -> a -> m r) -> a -> m r
getReader1 ChainDbHandle m blk
h ReaderKey
readerKey ChainDbEnv m blk -> a -> m r
f a
a = ChainDbHandle m blk
-> ReaderKey -> (ChainDbEnv m blk -> m r) -> m r
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack) =>
ChainDbHandle m blk
-> ReaderKey -> (ChainDbEnv m blk -> m r) -> m r
getReader ChainDbHandle m blk
h ReaderKey
readerKey (\ChainDbEnv m blk
env -> ChainDbEnv m blk -> a -> m r
f ChainDbEnv m blk
env a
a)

{-------------------------------------------------------------------------------
  Reader
-------------------------------------------------------------------------------}

newReader ::
     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)
newReader :: ChainDbHandle m blk
-> ResourceRegistry m -> BlockComponent blk b -> m (Reader m blk b)
newReader ChainDbHandle m blk
h ResourceRegistry m
registry BlockComponent blk b
blockComponent = ChainDbHandle m blk
-> (ChainDbEnv m blk -> m (Reader m blk b)) -> m (Reader m blk b)
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 (Reader m blk b)) -> m (Reader m blk b))
-> (ChainDbEnv m blk -> m (Reader m blk b)) -> m (Reader m blk b)
forall a b. (a -> b) -> a -> b
$ \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 :: 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
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
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
cdbReaders :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
..} -> do
    -- The following operations don't need to be done in a single transaction
    ReaderKey
readerKey  <- STM m ReaderKey -> m ReaderKey
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ReaderKey -> m ReaderKey) -> STM m ReaderKey -> m ReaderKey
forall a b. (a -> b) -> a -> b
$ StrictTVar m ReaderKey
-> (ReaderKey -> (ReaderKey, ReaderKey)) -> STM m ReaderKey
forall (m :: * -> *) a b.
MonadSTM m =>
StrictTVar m a -> (a -> (a, b)) -> STM m b
stateTVar StrictTVar m ReaderKey
cdbNextReaderKey ((ReaderKey -> (ReaderKey, ReaderKey)) -> STM m ReaderKey)
-> (ReaderKey -> (ReaderKey, ReaderKey)) -> STM m ReaderKey
forall a b. (a -> b) -> a -> b
$ \ReaderKey
r -> (ReaderKey -> ReaderKey
forall a. Enum a => a -> a
succ ReaderKey
r, ReaderKey
r)
    StrictTVar m (ReaderState m blk b)
varReader <- ReaderState m blk b -> m (StrictTVar m (ReaderState m blk b))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO ReaderState m blk b
forall (m :: * -> *) blk b. ReaderState m blk b
ReaderInit
    let readerHandle :: ReaderHandle m blk
readerHandle = StrictTVar m (ReaderState m blk b) -> ReaderHandle m blk
mkReaderHandle StrictTVar m (ReaderState m blk b)
varReader
    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
$ StrictTVar m (Map ReaderKey (ReaderHandle m blk))
-> (Map ReaderKey (ReaderHandle m blk)
    -> Map ReaderKey (ReaderHandle m blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbReaders ((Map ReaderKey (ReaderHandle m blk)
  -> Map ReaderKey (ReaderHandle m blk))
 -> STM m ())
-> (Map ReaderKey (ReaderHandle m blk)
    -> Map ReaderKey (ReaderHandle m blk))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ ReaderKey
-> ReaderHandle m blk
-> Map ReaderKey (ReaderHandle m blk)
-> Map ReaderKey (ReaderHandle m blk)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ReaderKey
readerKey ReaderHandle m blk
readerHandle
    let reader :: Reader m blk b
reader = ChainDbHandle m blk
-> ReaderKey
-> StrictTVar m (ReaderState m blk b)
-> ResourceRegistry m
-> BlockComponent blk b
-> Reader m blk b
forall (m :: * -> *) blk b.
(IOLike m, HasHeader blk, GetHeader blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
ChainDbHandle m blk
-> ReaderKey
-> StrictTVar m (ReaderState m blk b)
-> ResourceRegistry m
-> BlockComponent blk b
-> Reader m blk b
makeNewReader ChainDbHandle m blk
h ReaderKey
readerKey StrictTVar m (ReaderState m blk b)
varReader ResourceRegistry m
registry BlockComponent blk b
blockComponent
    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
$ TraceReaderEvent blk -> TraceEvent blk
forall blk. TraceReaderEvent blk -> TraceEvent blk
TraceReaderEvent TraceReaderEvent blk
forall blk. TraceReaderEvent blk
NewReader
    Reader m blk b -> m (Reader m blk b)
forall (m :: * -> *) a. Monad m => a -> m a
return Reader m blk b
reader
  where
    mkReaderHandle :: StrictTVar m (ReaderState m blk b) -> ReaderHandle m blk
    mkReaderHandle :: StrictTVar m (ReaderState m blk b) -> ReaderHandle m blk
mkReaderHandle StrictTVar m (ReaderState m blk b)
varReader = ReaderHandle :: forall (m :: * -> *) blk.
(Point blk -> AnchoredFragment (Header blk) -> STM m ())
-> m () -> ReaderHandle m blk
ReaderHandle
      { rhClose :: m ()
rhClose      = do
          -- This is only called by 'closeAllReaders'. We just release the
          -- resources. We don't check whether the Reader is still open.
          -- We don't have to remove the reader from the 'cdbReaders',
          -- 'closeAllReaders' will empty that map already.
          ReaderState m blk b
readerState <- STM m (ReaderState m blk b) -> m (ReaderState m blk b)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ReaderState m blk b) -> m (ReaderState m blk b))
-> STM m (ReaderState m blk b) -> m (ReaderState m blk b)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (ReaderState m blk b) -> STM m (ReaderState m blk b)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ReaderState m blk b)
varReader
          ReaderState m blk b -> m ()
forall (m :: * -> *) blk b.
MonadCatch m =>
ReaderState m blk b -> m ()
closeReaderState ReaderState m blk b
readerState
      , rhSwitchFork :: Point blk -> AnchoredFragment (Header blk) -> STM m ()
rhSwitchFork = \Point blk
ipoint AnchoredFragment (Header blk)
newChain -> StrictTVar m (ReaderState m blk b)
-> (ReaderState m blk b -> ReaderState m blk b) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (ReaderState m blk b)
varReader ((ReaderState m blk b -> ReaderState m blk b) -> STM m ())
-> (ReaderState m blk b -> ReaderState m blk b) -> STM m ()
forall a b. (a -> b) -> a -> b
$
          Point blk
-> AnchoredFragment (Header blk)
-> ReaderState m blk b
-> ReaderState m blk b
forall (m :: * -> *) blk b.
(HasHeader blk, HasHeader (Header blk)) =>
Point blk
-> AnchoredFragment (Header blk)
-> ReaderState m blk b
-> ReaderState m blk b
switchFork Point blk
ipoint AnchoredFragment (Header blk)
newChain
      }

makeNewReader ::
     forall m blk b.
     ( IOLike m
     , HasHeader blk
     , GetHeader blk
     , HasNestedContent Header blk
     , EncodeDiskDep (NestedCtxt Header) blk
     )
  => ChainDbHandle m blk
  -> ReaderKey
  -> StrictTVar m (ReaderState m blk b)
  -> ResourceRegistry m
  -> BlockComponent blk b
  -> Reader m blk b
makeNewReader :: ChainDbHandle m blk
-> ReaderKey
-> StrictTVar m (ReaderState m blk b)
-> ResourceRegistry m
-> BlockComponent blk b
-> Reader m blk b
makeNewReader ChainDbHandle m blk
h ReaderKey
readerKey StrictTVar m (ReaderState m blk b)
varReader ResourceRegistry m
registry BlockComponent blk b
blockComponent = Reader :: forall (m :: * -> *) blk a.
m (Maybe (ChainUpdate blk a))
-> m (ChainUpdate blk a)
-> ([Point blk] -> m (Maybe (Point blk)))
-> m ()
-> Reader m blk a
Reader {m (Maybe (ChainUpdate blk b))
m ()
m (ChainUpdate blk b)
[Point blk] -> m (Maybe (Point blk))
readerClose :: m ()
readerForward :: [Point blk] -> m (Maybe (Point blk))
readerInstructionBlocking :: m (ChainUpdate blk b)
readerInstruction :: m (Maybe (ChainUpdate blk b))
readerClose :: m ()
readerForward :: [Point blk] -> m (Maybe (Point blk))
readerInstructionBlocking :: m (ChainUpdate blk b)
readerInstruction :: m (Maybe (ChainUpdate blk b))
..}
  where
    readerInstruction :: m (Maybe (ChainUpdate blk b))
    readerInstruction :: m (Maybe (ChainUpdate blk b))
readerInstruction = ChainDbHandle m blk
-> ReaderKey
-> (ChainDbEnv m blk -> m (Maybe (ChainUpdate blk b)))
-> m (Maybe (ChainUpdate blk b))
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack) =>
ChainDbHandle m blk
-> ReaderKey -> (ChainDbEnv m blk -> m r) -> m r
getReader ChainDbHandle m blk
h ReaderKey
readerKey ((ChainDbEnv m blk -> m (Maybe (ChainUpdate blk b)))
 -> m (Maybe (ChainUpdate blk b)))
-> (ChainDbEnv m blk -> m (Maybe (ChainUpdate blk b)))
-> m (Maybe (ChainUpdate blk b))
forall a b. (a -> b) -> a -> b
$
      ResourceRegistry m
-> StrictTVar m (ReaderState m blk b)
-> BlockComponent blk b
-> (STM m (Maybe (ChainUpdate blk (Header blk)))
    -> STM m (Maybe (ChainUpdate blk (Header blk))))
-> ChainDbEnv m blk
-> m (Maybe (ChainUpdate blk b))
forall (m :: * -> *) blk b (f :: * -> *).
(IOLike m, HasHeader blk, GetHeader blk,
 HasNestedContent Header blk, EncodeDiskDep (NestedCtxt Header) blk,
 Traversable f, Applicative f) =>
ResourceRegistry m
-> StrictTVar m (ReaderState m blk b)
-> BlockComponent blk b
-> (STM m (Maybe (ChainUpdate blk (Header blk)))
    -> STM m (f (ChainUpdate blk (Header blk))))
-> ChainDbEnv m blk
-> m (f (ChainUpdate blk b))
instructionHelper ResourceRegistry m
registry StrictTVar m (ReaderState m blk b)
varReader BlockComponent blk b
blockComponent STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (Maybe (ChainUpdate blk (Header blk)))
forall a. a -> a
id

    readerInstructionBlocking :: m (ChainUpdate blk b)
    readerInstructionBlocking :: m (ChainUpdate blk b)
readerInstructionBlocking = (Identity (ChainUpdate blk b) -> ChainUpdate blk b)
-> m (Identity (ChainUpdate blk b)) -> m (ChainUpdate blk b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity (ChainUpdate blk b) -> ChainUpdate blk b
forall a. Identity a -> a
runIdentity (m (Identity (ChainUpdate blk b)) -> m (ChainUpdate blk b))
-> m (Identity (ChainUpdate blk b)) -> m (ChainUpdate blk b)
forall a b. (a -> b) -> a -> b
$
      ChainDbHandle m blk
-> ReaderKey
-> (ChainDbEnv m blk -> m (Identity (ChainUpdate blk b)))
-> m (Identity (ChainUpdate blk b))
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack) =>
ChainDbHandle m blk
-> ReaderKey -> (ChainDbEnv m blk -> m r) -> m r
getReader ChainDbHandle m blk
h ReaderKey
readerKey ((ChainDbEnv m blk -> m (Identity (ChainUpdate blk b)))
 -> m (Identity (ChainUpdate blk b)))
-> (ChainDbEnv m blk -> m (Identity (ChainUpdate blk b)))
-> m (Identity (ChainUpdate blk b))
forall a b. (a -> b) -> a -> b
$
      ResourceRegistry m
-> StrictTVar m (ReaderState m blk b)
-> BlockComponent blk b
-> (STM m (Maybe (ChainUpdate blk (Header blk)))
    -> STM m (Identity (ChainUpdate blk (Header blk))))
-> ChainDbEnv m blk
-> m (Identity (ChainUpdate blk b))
forall (m :: * -> *) blk b (f :: * -> *).
(IOLike m, HasHeader blk, GetHeader blk,
 HasNestedContent Header blk, EncodeDiskDep (NestedCtxt Header) blk,
 Traversable f, Applicative f) =>
ResourceRegistry m
-> StrictTVar m (ReaderState m blk b)
-> BlockComponent blk b
-> (STM m (Maybe (ChainUpdate blk (Header blk)))
    -> STM m (f (ChainUpdate blk (Header blk))))
-> ChainDbEnv m blk
-> m (f (ChainUpdate blk b))
instructionHelper ResourceRegistry m
registry StrictTVar m (ReaderState m blk b)
varReader BlockComponent blk b
blockComponent ((ChainUpdate blk (Header blk)
 -> Identity (ChainUpdate blk (Header blk)))
-> STM m (ChainUpdate blk (Header blk))
-> STM m (Identity (ChainUpdate blk (Header blk)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainUpdate blk (Header blk)
-> Identity (ChainUpdate blk (Header blk))
forall a. a -> Identity a
Identity (STM m (ChainUpdate blk (Header blk))
 -> STM m (Identity (ChainUpdate blk (Header blk))))
-> (STM m (Maybe (ChainUpdate blk (Header blk)))
    -> STM m (ChainUpdate blk (Header blk)))
-> STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (Identity (ChainUpdate blk (Header blk)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (ChainUpdate blk (Header blk))
forall (stm :: * -> *) a. MonadSTMTx stm => stm (Maybe a) -> stm a
blockUntilJust)

    readerForward :: [Point blk] -> m (Maybe (Point blk))
    readerForward :: [Point blk] -> m (Maybe (Point blk))
readerForward = ChainDbHandle m blk
-> ReaderKey
-> (ChainDbEnv m blk -> [Point blk] -> m (Maybe (Point blk)))
-> [Point blk]
-> m (Maybe (Point blk))
forall (m :: * -> *) blk a r.
IOLike m =>
ChainDbHandle m blk
-> ReaderKey -> (ChainDbEnv m blk -> a -> m r) -> a -> m r
getReader1 ChainDbHandle m blk
h ReaderKey
readerKey ((ChainDbEnv m blk -> [Point blk] -> m (Maybe (Point blk)))
 -> [Point blk] -> m (Maybe (Point blk)))
-> (ChainDbEnv m blk -> [Point blk] -> m (Maybe (Point blk)))
-> [Point blk]
-> m (Maybe (Point blk))
forall a b. (a -> b) -> a -> b
$
      ResourceRegistry m
-> StrictTVar m (ReaderState m blk b)
-> BlockComponent blk b
-> ChainDbEnv m blk
-> [Point blk]
-> m (Maybe (Point blk))
forall (m :: * -> *) blk b.
(IOLike m, HasCallStack, HasHeader blk, HasHeader (Header blk)) =>
ResourceRegistry m
-> StrictTVar m (ReaderState m blk b)
-> BlockComponent blk b
-> ChainDbEnv m blk
-> [Point blk]
-> m (Maybe (Point blk))
forward ResourceRegistry m
registry StrictTVar m (ReaderState m blk b)
varReader BlockComponent blk b
blockComponent

    readerClose :: m ()
    readerClose :: m ()
readerClose = 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 ()) -> m ())
-> (ChainDbEnv m blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ReaderKey
-> StrictTVar m (ReaderState m blk b) -> ChainDbEnv m blk -> m ()
forall (m :: * -> *) blk b.
IOLike m =>
ReaderKey
-> StrictTVar m (ReaderState m blk b) -> ChainDbEnv m blk -> m ()
close ReaderKey
readerKey StrictTVar m (ReaderState m blk b)
varReader

-- | Implementation of 'readerClose'.
--
-- To be called using 'getEnv' to make sure the ChainDB is still open.
--
-- Idempotent: the reader doesn't have to be open.
--
-- Unlike 'closeAllReaders', this is meant to be called by the user of the
-- ChainDB.Reader.
close ::
     forall m blk b. IOLike m
  => ReaderKey
  -> StrictTVar m (ReaderState m blk b)
  -> ChainDbEnv m blk
  -> m ()
close :: ReaderKey
-> StrictTVar m (ReaderState m blk b) -> ChainDbEnv m blk -> m ()
close ReaderKey
readerKey StrictTVar m (ReaderState m blk b)
varReader CDB { StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbReaders :: StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbReaders :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbReaders } = do
    -- If the ReaderKey is not present in the map, the Reader must have been
    -- closed already.
    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
$ StrictTVar m (Map ReaderKey (ReaderHandle m blk))
-> (Map ReaderKey (ReaderHandle m blk)
    -> Map ReaderKey (ReaderHandle m blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbReaders ((Map ReaderKey (ReaderHandle m blk)
  -> Map ReaderKey (ReaderHandle m blk))
 -> STM m ())
-> (Map ReaderKey (ReaderHandle m blk)
    -> Map ReaderKey (ReaderHandle m blk))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ ReaderKey
-> Map ReaderKey (ReaderHandle m blk)
-> Map ReaderKey (ReaderHandle m blk)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ReaderKey
readerKey
    ReaderState m blk b
readerState <- STM m (ReaderState m blk b) -> m (ReaderState m blk b)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ReaderState m blk b) -> m (ReaderState m blk b))
-> STM m (ReaderState m blk b) -> m (ReaderState m blk b)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (ReaderState m blk b) -> STM m (ReaderState m blk b)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ReaderState m blk b)
varReader
    ReaderState m blk b -> m ()
forall (m :: * -> *) blk b.
MonadCatch m =>
ReaderState m blk b -> m ()
closeReaderState ReaderState m blk b
readerState

-- | Close the given 'ReaderState' by closing any 'ImmutableDB.Iterator' it
-- might contain.
closeReaderState :: MonadCatch m => ReaderState m blk b -> m ()
closeReaderState :: ReaderState m blk b -> m ()
closeReaderState = \case
     ReaderState m blk b
ReaderInit                  -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     ReaderInMem ReaderRollState blk
_               -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     -- IMPORTANT: the main reason we're closing readers: to close this open
     -- iterator, which contains a reference to a file handle.
     ReaderInImmutableDB ReaderRollState blk
_ Iterator m blk (Point blk, b)
immIt -> Iterator m blk (Point blk, b) -> HasCallStack => m ()
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m ()
ImmutableDB.iteratorClose Iterator m blk (Point blk, b)
immIt

-- | Helper for 'readerInstruction' and 'readerInstructionBlocking'.
--
-- The type @f@ will be instantiated to:
--
-- * 'Maybe' in case of 'readerInstruction'.
-- * 'Identity' in case of 'readerInstructionBlocking'.
--
-- The returned 'ChainUpdate' contains a 'b', as defined by 'BlockComponent'.
--
-- When in the 'ReaderInImmutableDB' state, we never have to block, as we can
-- just stream the next block/header from the ImmutableDB.
--
-- When in the 'ReaderInMem' state, we may have to block when we have reached
-- the end of the current chain.
instructionHelper ::
     forall m blk b f.
     ( IOLike m
     , HasHeader blk
     , GetHeader blk
     , HasNestedContent Header blk
     , EncodeDiskDep (NestedCtxt Header) blk
     , Traversable f, Applicative f
     )
  => ResourceRegistry m
  -> StrictTVar m (ReaderState m blk b)
  -> BlockComponent blk b
  -> (    STM m (Maybe (ChainUpdate blk (Header blk)))
       -> STM m (f     (ChainUpdate blk (Header blk))))
     -- ^ How to turn a transaction that may or may not result in a new
     -- 'ChainUpdate' in one that returns the right return type: use @fmap
     -- Identity . 'blockUntilJust'@ to block or 'id' to just return the
     -- @Maybe@.
  -> ChainDbEnv m blk
  -> m (f (ChainUpdate blk b))
instructionHelper :: ResourceRegistry m
-> StrictTVar m (ReaderState m blk b)
-> BlockComponent blk b
-> (STM m (Maybe (ChainUpdate blk (Header blk)))
    -> STM m (f (ChainUpdate blk (Header blk))))
-> ChainDbEnv m blk
-> m (f (ChainUpdate blk b))
instructionHelper ResourceRegistry m
registry StrictTVar m (ReaderState m blk b)
varReader BlockComponent blk b
blockComponent STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (f (ChainUpdate blk (Header blk)))
fromMaybeSTM 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
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
cdbReaders :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
..} = do
    -- In one transaction: check in which state we are, if in the
    -- @ReaderInMem@ state, just call 'instructionSTM', otherwise,
    -- return the contents of the 'ReaderInImmutableDB' state.
    Either
  (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
  (f (ChainUpdate blk (Header blk)))
inImmutableDBOrRes <- STM
  m
  (Either
     (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk))))
-> m (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (Either
      (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
      (f (ChainUpdate blk (Header blk))))
 -> m (Either
         (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
         (f (ChainUpdate blk (Header blk)))))
-> STM
     m
     (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
-> m (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall a b. (a -> b) -> a -> b
$ do
      AnchoredFragment (Header blk)
curChain <- 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
      StrictTVar m (ReaderState m blk b) -> STM m (ReaderState m blk b)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ReaderState m blk b)
varReader STM m (ReaderState m blk b)
-> (ReaderState m blk b
    -> STM
         m
         (Either
            (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
            (f (ChainUpdate blk (Header blk)))))
-> STM
     m
     (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- Just return the contents of the state and end the transaction in
        -- these two cases.
        ReaderState m blk b
ReaderInit
          -> Either
  (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
  (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
   (f (ChainUpdate blk (Header blk)))
 -> STM
      m
      (Either
         (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
         (f (ChainUpdate blk (Header blk)))))
-> Either
     (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall a b. (a -> b) -> a -> b
$ (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
-> Either
     (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
forall a b. a -> Either a b
Left (Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollBackTo Point blk
forall block. Point block
GenesisPoint, Maybe (Iterator m blk (Point blk, b))
forall a. Maybe a
Nothing)
        ReaderInImmutableDB ReaderRollState blk
rollState Iterator m blk (Point blk, b)
immIt
          -> Either
  (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
  (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
   (f (ChainUpdate blk (Header blk)))
 -> STM
      m
      (Either
         (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
         (f (ChainUpdate blk (Header blk)))))
-> Either
     (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall a b. (a -> b) -> a -> b
$ (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
-> Either
     (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
forall a b. a -> Either a b
Left (ReaderRollState blk
rollState, Iterator m blk (Point blk, b)
-> Maybe (Iterator m blk (Point blk, b))
forall a. a -> Maybe a
Just Iterator m blk (Point blk, b)
immIt)

        ReaderInMem   ReaderRollState blk
rollState
          | Point (Header blk) -> AnchoredFragment (Header blk) -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds
            (Point blk -> Point (Header blk)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (ReaderRollState blk -> Point blk
forall blk. ReaderRollState blk -> Point blk
readerRollStatePoint ReaderRollState blk
rollState)) AnchoredFragment (Header blk)
curChain
            -- The point is still in the current chain fragment
          -> (f (ChainUpdate blk (Header blk))
 -> Either
      (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
      (f (ChainUpdate blk (Header blk))))
-> STM m (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (ChainUpdate blk (Header blk))
-> Either
     (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
forall a b. b -> Either a b
Right (STM m (f (ChainUpdate blk (Header blk)))
 -> STM
      m
      (Either
         (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
         (f (ChainUpdate blk (Header blk)))))
-> STM m (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall a b. (a -> b) -> a -> b
$ STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (f (ChainUpdate blk (Header blk)))
fromMaybeSTM (STM m (Maybe (ChainUpdate blk (Header blk)))
 -> STM m (f (ChainUpdate blk (Header blk))))
-> STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (f (ChainUpdate blk (Header blk)))
forall a b. (a -> b) -> a -> b
$
               ReaderRollState blk
-> AnchoredFragment (Header blk)
-> (ReaderRollState blk -> STM m ())
-> STM m (Maybe (ChainUpdate blk (Header blk)))
forall (stm :: * -> *) blk.
(MonadSTMTx stm, HasHeader (Header blk)) =>
ReaderRollState blk
-> AnchoredFragment (Header blk)
-> (ReaderRollState blk -> stm ())
-> stm (Maybe (ChainUpdate blk (Header blk)))
instructionSTM
                 ReaderRollState blk
rollState
                 AnchoredFragment (Header blk)
curChain
                 (StrictTVar m (ReaderState m blk b)
-> ReaderState m blk b -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ReaderState m blk b)
varReader (ReaderState m blk b -> STM m ())
-> (ReaderRollState blk -> ReaderState m blk b)
-> ReaderRollState blk
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderRollState blk -> ReaderState m blk b
forall (m :: * -> *) blk b.
ReaderRollState blk -> ReaderState m blk b
ReaderInMem)
          | Bool
otherwise
            -- The point is no longer on the fragment. Blocks must have moved
            -- (off the fragment) to the ImmutableDB. Note that 'switchFork'
            -- will try to keep the point on the fragment in case we switch to
            -- a fork.
          -> Either
  (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
  (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
   (f (ChainUpdate blk (Header blk)))
 -> STM
      m
      (Either
         (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
         (f (ChainUpdate blk (Header blk)))))
-> Either
     (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall a b. (a -> b) -> a -> b
$ (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
-> Either
     (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
forall a b. a -> Either a b
Left (ReaderRollState blk
rollState, Maybe (Iterator m blk (Point blk, b))
forall a. Maybe a
Nothing)
    case Either
  (ReaderRollState blk, Maybe (Iterator m blk (Point blk, b)))
  (f (ChainUpdate blk (Header blk)))
inImmutableDBOrRes of
      -- We were able to obtain the result inside the transaction as we were
      -- in the 'ReaderInMem' state. We only got a header, which we must first
      -- convert to the right block component.
      Right f (ChainUpdate blk (Header blk))
fupdate -> f (ChainUpdate blk (Header blk)) -> m (f (ChainUpdate blk b))
headerUpdateToBlockComponentUpdate f (ChainUpdate blk (Header blk))
fupdate
      -- We were in the 'ReaderInImmutableDB' state or we need to switch to it.
      Left (ReaderRollState blk
rollState, Maybe (Iterator m blk (Point blk, b))
mbImmIt) -> do
        Iterator m blk (Point blk, b)
immIt <- case Maybe (Iterator m blk (Point blk, b))
mbImmIt of
          Just Iterator m blk (Point blk, b)
immIt -> Iterator m blk (Point blk, b) -> m (Iterator m blk (Point blk, b))
forall (m :: * -> *) a. Monad m => a -> m a
return Iterator m blk (Point blk, b)
immIt
          -- We were in the 'ReaderInMem' state but have to switch to the
          -- 'ReaderInImmutableDB' state.
          Maybe (Iterator m blk (Point blk, b))
Nothing    -> do
            TraceReaderEvent blk -> m ()
trace (TraceReaderEvent blk -> m ()) -> TraceReaderEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ ReaderRollState blk -> TraceReaderEvent blk
forall blk. ReaderRollState blk -> TraceReaderEvent blk
ReaderNoLongerInMem ReaderRollState blk
rollState
            ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk (Point blk, b)
-> Point blk
-> m (Iterator m blk (Point blk, b))
forall (m :: * -> *) blk b.
(MonadSTM m, MonadThrow m, HasHeader blk, HasCallStack) =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Iterator m blk b)
ImmutableDB.streamAfterKnownPoint ImmutableDB m blk
cdbImmutableDB ResourceRegistry m
registry
              ((,) (Point blk -> b -> (Point blk, b))
-> BlockComponent blk (Point blk)
-> BlockComponent blk (b -> (Point blk, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockComponent blk (Point blk)
forall blk. BlockComponent blk (Point blk)
getPoint BlockComponent blk (b -> (Point blk, b))
-> BlockComponent blk b -> BlockComponent blk (Point blk, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk b
blockComponent)
              (ReaderRollState blk -> Point blk
forall blk. ReaderRollState blk -> Point blk
readerRollStatePoint ReaderRollState blk
rollState)
        case ReaderRollState blk
rollState of
          RollForwardFrom Point blk
pt -> Iterator m blk (Point blk, b)
-> Point blk -> m (f (ChainUpdate blk b))
rollForwardImmutableDB Iterator m blk (Point blk, b)
immIt Point blk
pt
          RollBackTo      Point blk
pt -> do
            let readerState' :: ReaderState m blk b
readerState' = ReaderRollState blk
-> Iterator m blk (Point blk, b) -> ReaderState m blk b
forall (m :: * -> *) blk b.
ReaderRollState blk
-> Iterator m blk (Point blk, b) -> ReaderState m blk b
ReaderInImmutableDB (Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollForwardFrom Point blk
pt) Iterator m blk (Point blk, b)
immIt
            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
$ StrictTVar m (ReaderState m blk b)
-> ReaderState m blk b -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ReaderState m blk b)
varReader ReaderState m blk b
readerState'
            f (ChainUpdate blk b) -> m (f (ChainUpdate blk b))
forall (m :: * -> *) a. Monad m => a -> m a
return (f (ChainUpdate blk b) -> m (f (ChainUpdate blk b)))
-> f (ChainUpdate blk b) -> m (f (ChainUpdate blk b))
forall a b. (a -> b) -> a -> b
$ ChainUpdate blk b -> f (ChainUpdate blk b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainUpdate blk b -> f (ChainUpdate blk b))
-> ChainUpdate blk b -> f (ChainUpdate blk b)
forall a b. (a -> b) -> a -> b
$ Point blk -> ChainUpdate blk b
forall block a. Point block -> ChainUpdate block a
RollBack Point blk
pt
  where
    trace :: TraceReaderEvent blk -> m ()
trace = Tracer m (TraceReaderEvent blk) -> TraceReaderEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith ((TraceReaderEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceReaderEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap TraceReaderEvent blk -> TraceEvent blk
forall blk. TraceReaderEvent blk -> TraceEvent blk
TraceReaderEvent Tracer m (TraceEvent blk)
cdbTracer)

    codecConfig :: CodecConfig blk
    codecConfig :: CodecConfig blk
codecConfig = TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig blk
cdbTopLevelConfig

    headerUpdateToBlockComponentUpdate
      :: f (ChainUpdate blk (Header blk)) -> m (f (ChainUpdate blk b))
    headerUpdateToBlockComponentUpdate :: f (ChainUpdate blk (Header blk)) -> m (f (ChainUpdate blk b))
headerUpdateToBlockComponentUpdate =
      (ChainUpdate blk (Header blk) -> m (ChainUpdate blk b))
-> f (ChainUpdate blk (Header blk)) -> m (f (ChainUpdate blk b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Header blk -> m b)
-> ChainUpdate blk (Header blk) -> m (ChainUpdate blk b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Header blk -> BlockComponent blk b -> m b
forall b'. Header blk -> BlockComponent blk b' -> m b'
`getBlockComponentFromHeader` BlockComponent blk b
blockComponent))

    -- | We only got the header for the in-memory chain fragment, so depending
    -- on the 'BlockComponent' that's requested, we might have to read the
    -- whole block.
    getBlockComponentFromHeader
      :: forall b'. Header blk -> BlockComponent blk b' -> m b'
    getBlockComponentFromHeader :: Header blk -> BlockComponent blk b' -> m b'
getBlockComponentFromHeader Header blk
hdr = \case
        BlockComponent blk b'
GetVerifiedBlock -> BlockComponent blk blk -> m blk
forall c. BlockComponent blk c -> m c
getBlockComponent BlockComponent blk blk
forall blk. BlockComponent blk blk
GetVerifiedBlock
        BlockComponent blk b'
GetBlock         -> BlockComponent blk blk -> m blk
forall c. BlockComponent blk c -> m c
getBlockComponent BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock
        BlockComponent blk b'
GetRawBlock      -> BlockComponent blk ByteString -> m ByteString
forall c. BlockComponent blk c -> m c
getBlockComponent BlockComponent blk ByteString
forall blk. BlockComponent blk ByteString
GetRawBlock
        BlockComponent blk b'
GetHeader        -> Header blk -> m (Header blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (Header blk -> m (Header blk)) -> Header blk -> m (Header blk)
forall a b. (a -> b) -> a -> b
$ Header blk
hdr
        BlockComponent blk b'
GetRawHeader     -> ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
rawHdr
        BlockComponent blk b'
GetHash          -> b' -> m b'
forall (m :: * -> *) a. Monad m => a -> m a
return (b' -> m b') -> b' -> m b'
forall a b. (a -> b) -> a -> b
$ Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr
        BlockComponent blk b'
GetSlot          -> SlotNo -> m SlotNo
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo -> m SlotNo) -> SlotNo -> m SlotNo
forall a b. (a -> b) -> a -> b
$ Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr
        BlockComponent blk b'
GetIsEBB         -> IsEBB -> m IsEBB
forall (m :: * -> *) a. Monad m => a -> m a
return (IsEBB -> m IsEBB) -> IsEBB -> m IsEBB
forall a b. (a -> b) -> a -> b
$ Header blk -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header blk
hdr
        BlockComponent blk b'
GetBlockSize     -> BlockComponent blk Word32 -> m Word32
forall c. BlockComponent blk c -> m c
getBlockComponent BlockComponent blk Word32
forall blk. BlockComponent blk Word32
GetBlockSize
        -- We could look up the header size in the index of the VolatileDB,
        -- but getting the serialisation is cheap because we keep the
        -- serialisation in memory as an annotation, and the following way is
        -- less stateful
        BlockComponent blk b'
GetHeaderSize    -> b' -> m b'
forall (m :: * -> *) a. Monad m => a -> m a
return (b' -> m b') -> b' -> m b'
forall a b. (a -> b) -> a -> b
$ Int64 -> b'
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> b') -> Int64 -> b'
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
Lazy.length ByteString
rawHdr
        BlockComponent blk b'
GetNestedCtxt    -> SomeSecond (NestedCtxt Header) blk
-> m (SomeSecond (NestedCtxt Header) blk)
forall (m :: * -> *) a. Monad m => a -> m a
return SomeSecond (NestedCtxt Header) blk
nestedCtxt
        GetPure b'
a        -> b' -> m b'
forall (m :: * -> *) a. Monad m => a -> m a
return b'
a
        GetApply BlockComponent blk (a -> b')
f BlockComponent blk a
bc    ->
          Header blk -> BlockComponent blk (a -> b') -> m (a -> b')
forall b'. Header blk -> BlockComponent blk b' -> m b'
getBlockComponentFromHeader Header blk
hdr BlockComponent blk (a -> b')
f m (a -> b') -> m a -> m b'
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
          Header blk -> BlockComponent blk a -> m a
forall b'. Header blk -> BlockComponent blk b' -> m b'
getBlockComponentFromHeader Header blk
hdr BlockComponent blk a
bc
      where
        -- | Use the 'ImmutableDB' and 'VolatileDB' to read the 'BlockComponent' from
        -- disk (or memory).
        getBlockComponent :: forall c. BlockComponent blk c -> m c
        getBlockComponent :: BlockComponent blk c -> m c
getBlockComponent BlockComponent blk c
bc =
          ImmutableDB m blk
-> VolatileDB m blk -> BlockComponent blk c -> RealPoint blk -> m c
forall (m :: * -> *) blk b.
(IOLike m, HasHeader blk) =>
ImmutableDB m blk
-> VolatileDB m blk -> BlockComponent blk b -> RealPoint blk -> m b
Query.getAnyKnownBlockComponent ImmutableDB m blk
cdbImmutableDB VolatileDB m blk
cdbVolatileDB BlockComponent blk c
bc (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr)

        rawHdr :: Lazy.ByteString
        nestedCtxt :: SomeSecond (NestedCtxt Header) blk
        (SomeSecond (NestedCtxt Header) blk
nestedCtxt, ByteString
rawHdr) = case Header blk -> DepPair (NestedCtxt Header blk)
forall (f :: * -> *) blk.
HasNestedContent f blk =>
f blk -> DepPair (NestedCtxt f blk)
unnest Header blk
hdr of
          DepPair NestedCtxt Header blk a
ctxt a
h ->
            ( NestedCtxt Header blk a -> SomeSecond (NestedCtxt Header) blk
forall (f :: * -> * -> *) a b. f a b -> SomeSecond f a
SomeSecond NestedCtxt Header blk a
ctxt
            , Encoding -> ByteString
toLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ CodecConfig blk -> NestedCtxt Header blk a -> a -> Encoding
forall (f :: * -> * -> *) blk a.
EncodeDiskDep f blk =>
CodecConfig blk -> f blk a -> a -> Encoding
encodeDiskDep CodecConfig blk
codecConfig NestedCtxt Header blk a
ctxt a
h
            )

    next ::
         ImmutableDB.Iterator m blk (Point blk, b)
      -> m (Maybe (Point blk, b))
    next :: Iterator m blk (Point blk, b) -> m (Maybe (Point blk, b))
next Iterator m blk (Point blk, b)
immIt = Iterator m blk (Point blk, b)
-> HasCallStack => m (IteratorResult (Point blk, b))
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m (IteratorResult b)
ImmutableDB.iteratorNext  Iterator m blk (Point blk, b)
immIt m (IteratorResult (Point blk, b))
-> (IteratorResult (Point blk, b) -> Maybe (Point blk, b))
-> m (Maybe (Point blk, b))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      ImmutableDB.IteratorResult  (Point blk, b)
b -> (Point blk, b) -> Maybe (Point blk, b)
forall a. a -> Maybe a
Just (Point blk, b)
b
      IteratorResult (Point blk, b)
ImmutableDB.IteratorExhausted -> Maybe (Point blk, b)
forall a. Maybe a
Nothing

    rollForwardImmutableDB ::
         ImmutableDB.Iterator m blk (Point blk, b)
      -> Point blk
      -> m (f (ChainUpdate blk b))
    rollForwardImmutableDB :: Iterator m blk (Point blk, b)
-> Point blk -> m (f (ChainUpdate blk b))
rollForwardImmutableDB Iterator m blk (Point blk, b)
immIt Point blk
pt = Iterator m blk (Point blk, b) -> m (Maybe (Point blk, b))
next Iterator m blk (Point blk, b)
immIt m (Maybe (Point blk, b))
-> (Maybe (Point blk, b) -> m (f (ChainUpdate blk b)))
-> m (f (ChainUpdate blk b))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (Point blk
pt', b
b) -> do
        let readerState' :: ReaderState m blk b
readerState' = ReaderRollState blk
-> Iterator m blk (Point blk, b) -> ReaderState m blk b
forall (m :: * -> *) blk b.
ReaderRollState blk
-> Iterator m blk (Point blk, b) -> ReaderState m blk b
ReaderInImmutableDB (Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollForwardFrom Point blk
pt') Iterator m blk (Point blk, b)
immIt
        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
$ StrictTVar m (ReaderState m blk b)
-> ReaderState m blk b -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ReaderState m blk b)
varReader ReaderState m blk b
readerState'
        f (ChainUpdate blk b) -> m (f (ChainUpdate blk b))
forall (m :: * -> *) a. Monad m => a -> m a
return (f (ChainUpdate blk b) -> m (f (ChainUpdate blk b)))
-> f (ChainUpdate blk b) -> m (f (ChainUpdate blk b))
forall a b. (a -> b) -> a -> b
$ ChainUpdate blk b -> f (ChainUpdate blk b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainUpdate blk b -> f (ChainUpdate blk b))
-> ChainUpdate blk b -> f (ChainUpdate blk b)
forall a b. (a -> b) -> a -> b
$ b -> ChainUpdate blk b
forall block a. a -> ChainUpdate block a
AddBlock b
b
      Maybe (Point blk, b)
Nothing  -> do
        -- Even though an iterator is automatically closed internally when
        -- exhausted, we close it again (idempotent), but this time to
        -- unregister the associated clean-up action.
        Iterator m blk (Point blk, b) -> HasCallStack => m ()
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m ()
ImmutableDB.iteratorClose Iterator m blk (Point blk, b)
immIt
        -- The iterator is exhausted: we've reached the end of the
        -- ImmutableDB, or actually what was the end of the ImmutableDB at the
        -- time of opening the iterator. We must now check whether that is
        -- still the end (blocks might have been added to the ImmutableDB in
        -- the meantime).
        Point blk
pointAtImmutableDBTip
          <- 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
cdbImmutableDB
        let slotNoAtImmutableDBTip :: WithOrigin SlotNo
slotNoAtImmutableDBTip = Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
pointAtImmutableDBTip
        case Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
pt WithOrigin SlotNo -> WithOrigin SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` WithOrigin SlotNo
slotNoAtImmutableDBTip of
          -- The ImmutableDB somehow rolled back
          Ordering
GT -> [Char] -> m (f (ChainUpdate blk b))
forall a. HasCallStack => [Char] -> a
error [Char]
"reader streamed beyond tip of the ImmutableDB"

          -- The tip is still the same, so switch to the in-memory chain
          Ordering
EQ | Point blk
pt Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
pointAtImmutableDBTip
             -> do
            TraceReaderEvent blk -> m ()
trace (TraceReaderEvent blk -> m ()) -> TraceReaderEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> WithOrigin SlotNo -> TraceReaderEvent blk
forall blk. Point blk -> WithOrigin SlotNo -> TraceReaderEvent blk
ReaderSwitchToMem Point blk
pt WithOrigin SlotNo
slotNoAtImmutableDBTip
            f (ChainUpdate blk (Header blk))
fupdate <- STM m (f (ChainUpdate blk (Header blk)))
-> m (f (ChainUpdate blk (Header blk)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (f (ChainUpdate blk (Header blk)))
 -> m (f (ChainUpdate blk (Header blk))))
-> STM m (f (ChainUpdate blk (Header blk)))
-> m (f (ChainUpdate blk (Header blk)))
forall a b. (a -> b) -> a -> b
$ STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (f (ChainUpdate blk (Header blk)))
fromMaybeSTM (STM m (Maybe (ChainUpdate blk (Header blk)))
 -> STM m (f (ChainUpdate blk (Header blk))))
-> STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (f (ChainUpdate blk (Header blk)))
forall a b. (a -> b) -> a -> b
$ do
              AnchoredFragment (Header blk)
curChain <- 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
              ReaderRollState blk
-> AnchoredFragment (Header blk)
-> (ReaderRollState blk -> STM m ())
-> STM m (Maybe (ChainUpdate blk (Header blk)))
forall (stm :: * -> *) blk.
(MonadSTMTx stm, HasHeader (Header blk)) =>
ReaderRollState blk
-> AnchoredFragment (Header blk)
-> (ReaderRollState blk -> stm ())
-> stm (Maybe (ChainUpdate blk (Header blk)))
instructionSTM
                (Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollForwardFrom Point blk
pt)
                AnchoredFragment (Header blk)
curChain
                (StrictTVar m (ReaderState m blk b)
-> ReaderState m blk b -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ReaderState m blk b)
varReader (ReaderState m blk b -> STM m ())
-> (ReaderRollState blk -> ReaderState m blk b)
-> ReaderRollState blk
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderRollState blk -> ReaderState m blk b
forall (m :: * -> *) blk b.
ReaderRollState blk -> ReaderState m blk b
ReaderInMem)
            -- We only got the header, we must first convert it to the right
            -- block component.
            f (ChainUpdate blk (Header blk)) -> m (f (ChainUpdate blk b))
headerUpdateToBlockComponentUpdate f (ChainUpdate blk (Header blk))
fupdate

          -- Two possibilities:
          --
          -- 1. (EQ): the tip changed, but the slot number is the same. This
          --    is only possible when an EBB was at the tip and the regular
          --    block in the same slot was appended to the ImmutableDB.
          --
          -- 2. (LT): the tip of the ImmutableDB has progressed since we
          --    opened the iterator.
          Ordering
_  -> do
            TraceReaderEvent blk -> m ()
trace (TraceReaderEvent blk -> m ()) -> TraceReaderEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> WithOrigin SlotNo -> TraceReaderEvent blk
forall blk. Point blk -> WithOrigin SlotNo -> TraceReaderEvent blk
ReaderNewImmIterator Point blk
pt WithOrigin SlotNo
slotNoAtImmutableDBTip
            Iterator m blk (Point blk, b)
immIt' <- ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk (Point blk, b)
-> Point blk
-> m (Iterator m blk (Point blk, b))
forall (m :: * -> *) blk b.
(MonadSTM m, MonadThrow m, HasHeader blk, HasCallStack) =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Iterator m blk b)
ImmutableDB.streamAfterKnownPoint ImmutableDB m blk
cdbImmutableDB ResourceRegistry m
registry
              ((,) (Point blk -> b -> (Point blk, b))
-> BlockComponent blk (Point blk)
-> BlockComponent blk (b -> (Point blk, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockComponent blk (Point blk)
forall blk. BlockComponent blk (Point blk)
getPoint BlockComponent blk (b -> (Point blk, b))
-> BlockComponent blk b -> BlockComponent blk (Point blk, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk b
blockComponent) Point blk
pt
            -- Try again with the new iterator
            Iterator m blk (Point blk, b)
-> Point blk -> m (f (ChainUpdate blk b))
rollForwardImmutableDB Iterator m blk (Point blk, b)
immIt' Point blk
pt

-- | 'readerInstruction' for when the reader is in the 'ReaderInMem' state.
instructionSTM ::
     forall stm blk. (MonadSTMTx stm, HasHeader (Header blk))
  => ReaderRollState blk
     -- ^ The current 'ReaderRollState' of the reader
  -> AnchoredFragment (Header blk)
     -- ^ The current chain fragment
  -> (ReaderRollState blk -> stm ())
     -- ^ How to save the updated 'ReaderRollState'
  -> stm (Maybe (ChainUpdate blk (Header blk)))
instructionSTM :: ReaderRollState blk
-> AnchoredFragment (Header blk)
-> (ReaderRollState blk -> stm ())
-> stm (Maybe (ChainUpdate blk (Header blk)))
instructionSTM ReaderRollState blk
rollState AnchoredFragment (Header blk)
curChain ReaderRollState blk -> stm ()
saveRollState =
    Bool
-> stm (Maybe (ChainUpdate blk (Header blk)))
-> stm (Maybe (ChainUpdate blk (Header blk)))
forall a. HasCallStack => Bool -> a -> a
assert (AnchoredFragment (Header blk) -> Bool
invariant AnchoredFragment (Header blk)
curChain) (stm (Maybe (ChainUpdate blk (Header blk)))
 -> stm (Maybe (ChainUpdate blk (Header blk))))
-> stm (Maybe (ChainUpdate blk (Header blk)))
-> stm (Maybe (ChainUpdate blk (Header blk)))
forall a b. (a -> b) -> a -> b
$ case ReaderRollState blk
rollState of
      RollForwardFrom Point blk
pt ->
        case Point (Header blk)
-> AnchoredFragment (Header blk) -> Maybe (Header blk)
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Maybe block
AF.successorBlock (Point blk -> Point (Header blk)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
pt) AnchoredFragment (Header blk)
curChain of
          -- There is no successor block because the reader is at the head
          Maybe (Header blk)
Nothing  -> Maybe (ChainUpdate blk (Header blk))
-> stm (Maybe (ChainUpdate blk (Header blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ChainUpdate blk (Header blk))
forall a. Maybe a
Nothing
          Just Header blk
hdr -> do
            ReaderRollState blk -> stm ()
saveRollState (ReaderRollState blk -> stm ()) -> ReaderRollState blk -> stm ()
forall a b. (a -> b) -> a -> b
$ Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollForwardFrom (Point blk -> ReaderRollState blk)
-> Point blk -> ReaderRollState blk
forall a b. (a -> b) -> a -> b
$ Header blk -> Point blk
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint Header blk
hdr
            Maybe (ChainUpdate blk (Header blk))
-> stm (Maybe (ChainUpdate blk (Header blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ChainUpdate blk (Header blk))
 -> stm (Maybe (ChainUpdate blk (Header blk))))
-> Maybe (ChainUpdate blk (Header blk))
-> stm (Maybe (ChainUpdate blk (Header blk)))
forall a b. (a -> b) -> a -> b
$ ChainUpdate blk (Header blk)
-> Maybe (ChainUpdate blk (Header blk))
forall a. a -> Maybe a
Just (ChainUpdate blk (Header blk)
 -> Maybe (ChainUpdate blk (Header blk)))
-> ChainUpdate blk (Header blk)
-> Maybe (ChainUpdate blk (Header blk))
forall a b. (a -> b) -> a -> b
$ Header blk -> ChainUpdate blk (Header blk)
forall block a. a -> ChainUpdate block a
AddBlock Header blk
hdr
      RollBackTo      Point blk
pt -> do
        ReaderRollState blk -> stm ()
saveRollState (ReaderRollState blk -> stm ()) -> ReaderRollState blk -> stm ()
forall a b. (a -> b) -> a -> b
$ Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollForwardFrom Point blk
pt
        Maybe (ChainUpdate blk (Header blk))
-> stm (Maybe (ChainUpdate blk (Header blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ChainUpdate blk (Header blk))
 -> stm (Maybe (ChainUpdate blk (Header blk))))
-> Maybe (ChainUpdate blk (Header blk))
-> stm (Maybe (ChainUpdate blk (Header blk)))
forall a b. (a -> b) -> a -> b
$ ChainUpdate blk (Header blk)
-> Maybe (ChainUpdate blk (Header blk))
forall a. a -> Maybe a
Just (ChainUpdate blk (Header blk)
 -> Maybe (ChainUpdate blk (Header blk)))
-> ChainUpdate blk (Header blk)
-> Maybe (ChainUpdate blk (Header blk))
forall a b. (a -> b) -> a -> b
$ Point blk -> ChainUpdate blk (Header blk)
forall block a. Point block -> ChainUpdate block a
RollBack Point blk
pt
  where
    invariant :: AnchoredFragment (Header blk) -> Bool
invariant =
      Point (Header blk) -> AnchoredFragment (Header blk) -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds (Point blk -> Point (Header blk)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (ReaderRollState blk -> Point blk
forall blk. ReaderRollState blk -> Point blk
readerRollStatePoint ReaderRollState blk
rollState))

forward ::
     forall m blk b.
     ( IOLike m
     , HasCallStack
     , HasHeader blk
     , HasHeader (Header blk)
     )
  => ResourceRegistry m
  -> StrictTVar m (ReaderState m blk b)
  -> BlockComponent blk b
  -> ChainDbEnv m blk
  -> [Point blk]
  -> m (Maybe (Point blk))
forward :: ResourceRegistry m
-> StrictTVar m (ReaderState m blk b)
-> BlockComponent blk b
-> ChainDbEnv m blk
-> [Point blk]
-> m (Maybe (Point blk))
forward ResourceRegistry m
registry StrictTVar m (ReaderState m blk b)
varReader BlockComponent blk b
blockComponent 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
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
cdbReaders :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
..} = \[Point blk]
pts -> do
    -- NOTE: we don't use 'Query.getCurrentChain', which only returns the last
    -- @k@ headers, because we want to see the headers that have not yet been
    -- written to the ImmutableDB too.
    (AnchoredFragment (Header blk)
curChain, ReaderState m blk b
readerState) <- STM m (AnchoredFragment (Header blk), ReaderState m blk b)
-> m (AnchoredFragment (Header blk), ReaderState m blk b)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (AnchoredFragment (Header blk), ReaderState m blk b)
 -> m (AnchoredFragment (Header blk), ReaderState m blk b))
-> STM m (AnchoredFragment (Header blk), ReaderState m blk b)
-> m (AnchoredFragment (Header blk), ReaderState m blk b)
forall a b. (a -> b) -> a -> b
$
      (,) (AnchoredFragment (Header blk)
 -> ReaderState m blk b
 -> (AnchoredFragment (Header blk), ReaderState m blk b))
-> STM m (AnchoredFragment (Header blk))
-> STM
     m
     (ReaderState m blk b
      -> (AnchoredFragment (Header blk), ReaderState m blk b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 STM
  m
  (ReaderState m blk b
   -> (AnchoredFragment (Header blk), ReaderState m blk b))
-> STM m (ReaderState m blk b)
-> STM m (AnchoredFragment (Header blk), ReaderState m blk b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrictTVar m (ReaderState m blk b) -> STM m (ReaderState m blk b)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ReaderState m blk b)
varReader
    WithOrigin SlotNo
slotNoAtImmutableDBTip <- STM m (WithOrigin SlotNo) -> m (WithOrigin SlotNo)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithOrigin SlotNo) -> m (WithOrigin SlotNo))
-> STM m (WithOrigin SlotNo) -> m (WithOrigin SlotNo)
forall a b. (a -> b) -> a -> b
$
      ImmutableDB m blk -> STM m (WithOrigin SlotNo)
forall (m :: * -> *) blk.
(MonadSTM m, HasCallStack) =>
ImmutableDB m blk -> STM m (WithOrigin SlotNo)
ImmutableDB.getTipSlot ImmutableDB m blk
cdbImmutableDB
    HasCallStack =>
AnchoredFragment (Header blk)
-> ReaderState m blk b
-> WithOrigin SlotNo
-> [Point blk]
-> m (Maybe (Point blk))
AnchoredFragment (Header blk)
-> ReaderState m blk b
-> WithOrigin SlotNo
-> [Point blk]
-> m (Maybe (Point blk))
findFirstPointOnChain AnchoredFragment (Header blk)
curChain ReaderState m blk b
readerState WithOrigin SlotNo
slotNoAtImmutableDBTip [Point blk]
pts
  where
    findFirstPointOnChain ::
         HasCallStack
      => AnchoredFragment (Header blk)
      -> ReaderState m blk b
      -> WithOrigin SlotNo
      -> [Point blk]
      -> m (Maybe (Point blk))
    findFirstPointOnChain :: AnchoredFragment (Header blk)
-> ReaderState m blk b
-> WithOrigin SlotNo
-> [Point blk]
-> m (Maybe (Point blk))
findFirstPointOnChain AnchoredFragment (Header blk)
curChain ReaderState m blk b
readerState WithOrigin SlotNo
slotNoAtImmutableDBTip = \case
      []     -> Maybe (Point blk) -> m (Maybe (Point blk))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Point blk)
forall a. Maybe a
Nothing
      Point blk
pt:[Point blk]
pts
        | Point (Header blk) -> AnchoredFragment (Header blk) -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds (Point blk -> Point (Header blk)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
pt) AnchoredFragment (Header blk)
curChain
        -> do
          -- It's in the in-memory chain fragment.
          ReaderState m blk b -> m ()
updateState (ReaderState m blk b -> m ()) -> ReaderState m blk b -> m ()
forall a b. (a -> b) -> a -> b
$ ReaderRollState blk -> ReaderState m blk b
forall (m :: * -> *) blk b.
ReaderRollState blk -> ReaderState m blk b
ReaderInMem (ReaderRollState blk -> ReaderState m blk b)
-> ReaderRollState blk -> ReaderState m blk b
forall a b. (a -> b) -> a -> b
$ Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollBackTo Point blk
pt
          Maybe (Point blk) -> m (Maybe (Point blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Point blk) -> m (Maybe (Point blk)))
-> Maybe (Point blk) -> m (Maybe (Point blk))
forall a b. (a -> b) -> a -> b
$ Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just Point blk
pt

        | Bool
otherwise
        -- Not in the in-memory chain fragment, so older than @k@, hence it
        -- should be in the ImmutableDB. If not, then the point is not on our
        -- chain.
        --
        -- We try to avoid IO (in the ImmutableDB) as much as possible by
        -- checking whether the requested point corresponds to the current
        -- state of the reader.
        -> case ReaderState m blk b
readerState of
            ReaderState m blk b
ReaderInit
              | Point blk
pt Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
forall block. Point block
GenesisPoint
              -- The 'ReaderInit' state is equivalent to @'RollBackTo'
              -- 'genesisPoint'@, so the state doesn't have to change when
              -- requesting a rollback to genesis.
              -> Maybe (Point blk) -> m (Maybe (Point blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Point blk) -> m (Maybe (Point blk)))
-> Maybe (Point blk) -> m (Maybe (Point blk))
forall a b. (a -> b) -> a -> b
$ Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just Point blk
pt

            ReaderInImmutableDB ReaderRollState blk
rollState Iterator m blk (Point blk, b)
immIt
              | ReaderRollState blk
rollState ReaderRollState blk -> ReaderRollState blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollBackTo Point blk
pt
              -- If we already have to roll back to the given point in the
              -- ImmutableDB, the state doesn't have to change, saving us from
              -- checking whether the point is in the ImmutableDB (cached disk
              -- reads), closing, and opening the same ImmutableDB iterator.
              -> Maybe (Point blk) -> m (Maybe (Point blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Point blk) -> m (Maybe (Point blk)))
-> Maybe (Point blk) -> m (Maybe (Point blk))
forall a b. (a -> b) -> a -> b
$ Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just Point blk
pt

              | ReaderRollState blk
rollState ReaderRollState blk -> ReaderRollState blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollForwardFrom Point blk
pt
              -- If we're already rolling forward from the given point in the
              -- ImmutableDB, we can reuse the open ImmutableDB iterator,
              -- saving the same costs as in the comment above. We do have to
              -- update the state from 'RollForwardFrom' to 'RollBackTo'.
              -> do
                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
$ StrictTVar m (ReaderState m blk b)
-> ReaderState m blk b -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ReaderState m blk b)
varReader (ReaderState m blk b -> STM m ())
-> ReaderState m blk b -> STM m ()
forall a b. (a -> b) -> a -> b
$
                  ReaderRollState blk
-> Iterator m blk (Point blk, b) -> ReaderState m blk b
forall (m :: * -> *) blk b.
ReaderRollState blk
-> Iterator m blk (Point blk, b) -> ReaderState m blk b
ReaderInImmutableDB (Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollBackTo Point blk
pt) Iterator m blk (Point blk, b)
immIt
                Maybe (Point blk) -> m (Maybe (Point blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Point blk) -> m (Maybe (Point blk)))
-> Maybe (Point blk) -> m (Maybe (Point blk))
forall a b. (a -> b) -> a -> b
$ Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just Point blk
pt

            ReaderState m blk b
_otherwise -> case Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point blk
pt of
              -- Genesis is always "in" the ImmutableDB
              WithOrigin (RealPoint blk)
Origin -> do
                ReaderState m blk b -> m ()
updateState ReaderState m blk b
forall (m :: * -> *) blk b. ReaderState m blk b
ReaderInit
                Maybe (Point blk) -> m (Maybe (Point blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Point blk) -> m (Maybe (Point blk)))
-> Maybe (Point blk) -> m (Maybe (Point blk))
forall a b. (a -> b) -> a -> b
$ Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just Point blk
pt

              NotOrigin RealPoint blk
pt' -> do
                Bool
inImmutableDB <- ImmutableDB m blk -> RealPoint blk -> m Bool
forall (m :: * -> *) blk.
(MonadSTM m, HasCallStack) =>
ImmutableDB m blk -> RealPoint blk -> m Bool
ImmutableDB.hasBlock ImmutableDB m blk
cdbImmutableDB RealPoint blk
pt'
                if Bool
inImmutableDB then do
                  Iterator m blk (Point blk, b)
immIt <- ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk (Point blk, b)
-> Point blk
-> m (Iterator m blk (Point blk, b))
forall (m :: * -> *) blk b.
(MonadSTM m, MonadThrow m, HasHeader blk, HasCallStack) =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Iterator m blk b)
ImmutableDB.streamAfterKnownPoint ImmutableDB m blk
cdbImmutableDB ResourceRegistry m
registry
                    ((,) (Point blk -> b -> (Point blk, b))
-> BlockComponent blk (Point blk)
-> BlockComponent blk (b -> (Point blk, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockComponent blk (Point blk)
forall blk. BlockComponent blk (Point blk)
getPoint BlockComponent blk (b -> (Point blk, b))
-> BlockComponent blk b -> BlockComponent blk (Point blk, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk b
blockComponent) Point blk
pt
                  ReaderState m blk b -> m ()
updateState (ReaderState m blk b -> m ()) -> ReaderState m blk b -> m ()
forall a b. (a -> b) -> a -> b
$ ReaderRollState blk
-> Iterator m blk (Point blk, b) -> ReaderState m blk b
forall (m :: * -> *) blk b.
ReaderRollState blk
-> Iterator m blk (Point blk, b) -> ReaderState m blk b
ReaderInImmutableDB (Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollBackTo Point blk
pt) Iterator m blk (Point blk, b)
immIt
                  Maybe (Point blk) -> m (Maybe (Point blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Point blk) -> m (Maybe (Point blk)))
-> Maybe (Point blk) -> m (Maybe (Point blk))
forall a b. (a -> b) -> a -> b
$ Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just Point blk
pt
                else
                  -- The point is not in the current chain, try the next point
                  HasCallStack =>
AnchoredFragment (Header blk)
-> ReaderState m blk b
-> WithOrigin SlotNo
-> [Point blk]
-> m (Maybe (Point blk))
AnchoredFragment (Header blk)
-> ReaderState m blk b
-> WithOrigin SlotNo
-> [Point blk]
-> m (Maybe (Point blk))
findFirstPointOnChain AnchoredFragment (Header blk)
curChain ReaderState m blk b
readerState WithOrigin SlotNo
slotNoAtImmutableDBTip [Point blk]
pts

    -- | Update the state of the reader to the given state. If the current
    -- state is 'ReaderInImmutableDB', close the ImmutableDB iterator to avoid
    -- leaking the file handles.
    updateState :: ReaderState m blk b -> m ()
    updateState :: ReaderState m blk b -> m ()
updateState ReaderState m blk b
newReaderState = m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ 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 (ReaderState m blk b)
-> (ReaderState m blk b -> (ReaderState m blk b, m ()))
-> STM m (m ())
forall (m :: * -> *) a b.
MonadSTM m =>
StrictTVar m a -> (a -> (a, b)) -> STM m b
stateTVar StrictTVar m (ReaderState m blk b)
varReader ((ReaderState m blk b -> (ReaderState m blk b, m ()))
 -> STM m (m ()))
-> (ReaderState m blk b -> (ReaderState m blk b, m ()))
-> STM m (m ())
forall a b. (a -> b) -> a -> b
$ \ReaderState m blk b
readerState ->
        (ReaderState m blk b
newReaderState, ) (m () -> (ReaderState m blk b, m ()))
-> m () -> (ReaderState m blk b, m ())
forall a b. (a -> b) -> a -> b
$ case ReaderState m blk b
readerState of
          -- Return a continuation (that we'll 'join') that closes the
          -- previous iterator.
          ReaderInImmutableDB ReaderRollState blk
_ Iterator m blk (Point blk, b)
immIt -> Iterator m blk (Point blk, b) -> HasCallStack => m ()
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m ()
ImmutableDB.iteratorClose Iterator m blk (Point blk, b)
immIt
          ReaderState m blk b
ReaderInit                  -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          ReaderInMem ReaderRollState blk
_               -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Update the given 'ReaderState' to account for switching the current
-- chain to the given fork (which might just be an extension of the
-- current chain).
--
-- PRECONDITION: the intersection point must be within the fragment bounds
-- of the new chain
switchFork ::
     forall m blk b. (HasHeader blk, HasHeader (Header blk))
  => Point blk  -- ^ Intersection point between old and new chain
  -> AnchoredFragment (Header blk)  -- ^ The new chain
  -> ReaderState m blk b -> ReaderState m blk b
switchFork :: Point blk
-> AnchoredFragment (Header blk)
-> ReaderState m blk b
-> ReaderState m blk b
switchFork Point blk
ipoint AnchoredFragment (Header blk)
newChain ReaderState m blk b
readerState =
    Bool -> ReaderState m blk b -> ReaderState m blk b
forall a. HasCallStack => Bool -> a -> a
assert (Point (Header blk) -> AnchoredFragment (Header blk) -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds (Point blk -> Point (Header blk)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
ipoint) AnchoredFragment (Header blk)
newChain) (ReaderState m blk b -> ReaderState m blk b)
-> ReaderState m blk b -> ReaderState m blk b
forall a b. (a -> b) -> a -> b
$
      case ReaderState m blk b
readerState of
        -- If the reader is still in the initial state, switching to a fork
        -- won't affect it.
        ReaderState m blk b
ReaderInit             -> ReaderState m blk b
readerState
        -- If the reader is still reading from the ImmutableDB, switching to a
        -- fork won't affect it.
        ReaderInImmutableDB {} -> ReaderState m blk b
readerState
        ReaderInMem ReaderRollState blk
rollState  ->
            case Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
readerPoint WithOrigin SlotNo -> WithOrigin SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
ipoint of
              -- If the reader point is more recent than the intersection point,
              -- we have to roll back the reader to the intersection point.
              Ordering
GT -> ReaderRollState blk -> ReaderState m blk b
forall (m :: * -> *) blk b.
ReaderRollState blk -> ReaderState m blk b
ReaderInMem (ReaderRollState blk -> ReaderState m blk b)
-> ReaderRollState blk -> ReaderState m blk b
forall a b. (a -> b) -> a -> b
$ Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollBackTo Point blk
ipoint

              -- The reader point and the intersection point are in the same
              -- slot. We have to be careful here, because one (or both) of them
              -- could be an EBB.
              Ordering
EQ
                | Point blk -> ChainHash blk
forall block. Point block -> ChainHash block
pointHash Point blk
readerPoint ChainHash blk -> ChainHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk -> ChainHash blk
forall block. Point block -> ChainHash block
pointHash Point blk
ipoint
                  -- The same point, so no rollback needed.
                -> ReaderState m blk b
readerState
                | Just Point blk
pointAfterRollStatePoint <- Header blk -> Point blk
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint (Header blk -> Point blk)
-> Maybe (Header blk) -> Maybe (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    Point (Header blk)
-> AnchoredFragment (Header blk) -> Maybe (Header blk)
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Maybe block
AF.successorBlock (Point blk -> Point (Header blk)
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
readerPoint) AnchoredFragment (Header blk)
newChain
                , Point blk
pointAfterRollStatePoint Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
ipoint
                  -- The point after the reader point is the intersection
                  -- point. It must be that the reader point is an EBB and
                  -- that the intersection point is a regular block in the
                  -- same slot. As the reader point is older than the
                  -- intersection point, no rollback is needed.
                -> ReaderState m blk b
readerState
                | Bool
otherwise
                  -- Either the intersection point is the EBB before the
                  -- reader point (referring to the regular block in the same
                  -- slot), in which case we need to roll back, as the
                  -- intersection point is older than the reader point. Or,
                  -- we're dealing with two blocks (could be two EBBs) in the
                  -- same slot with a different hash, in which case we'll have
                  -- to rollback to the intersection point.
                -> ReaderRollState blk -> ReaderState m blk b
forall (m :: * -> *) blk b.
ReaderRollState blk -> ReaderState m blk b
ReaderInMem (ReaderRollState blk -> ReaderState m blk b)
-> ReaderRollState blk -> ReaderState m blk b
forall a b. (a -> b) -> a -> b
$ Point blk -> ReaderRollState blk
forall blk. Point blk -> ReaderRollState blk
RollBackTo Point blk
ipoint

              -- The reader point is older than the intersection point, so we
              -- can keep rolling forward. Note that this does not mean the
              -- reader point is still on the current fragment, as headers older
              -- than @k@ might have been moved from the fragment to the
              -- ImmutableDB. This will be noticed when the next instruction is
              -- requested; we'll switch to the 'ReaderInImmutableDB' state.
              Ordering
LT -> ReaderState m blk b
readerState
          where
            readerPoint :: Point blk
readerPoint = ReaderRollState blk -> Point blk
forall blk. ReaderRollState blk -> Point blk
readerRollStatePoint ReaderRollState blk
rollState

-- | Close all open block and header 'Reader's.
closeAllReaders :: IOLike m => ChainDbEnv m blk -> m ()
closeAllReaders :: ChainDbEnv m blk -> m ()
closeAllReaders 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
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
cdbReaders :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
..} = do
    [ReaderHandle m blk]
readerHandles <- STM m [ReaderHandle m blk] -> m [ReaderHandle m blk]
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [ReaderHandle m blk] -> m [ReaderHandle m blk])
-> STM m [ReaderHandle m blk] -> m [ReaderHandle m blk]
forall a b. (a -> b) -> a -> b
$ do
      [ReaderHandle m blk]
readerHandles  <- Map ReaderKey (ReaderHandle m blk) -> [ReaderHandle m blk]
forall k a. Map k a -> [a]
Map.elems (Map ReaderKey (ReaderHandle m blk) -> [ReaderHandle m blk])
-> STM m (Map ReaderKey (ReaderHandle m blk))
-> STM m [ReaderHandle m blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map ReaderKey (ReaderHandle m blk))
-> STM m (Map ReaderKey (ReaderHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbReaders
      StrictTVar m (Map ReaderKey (ReaderHandle m blk))
-> Map ReaderKey (ReaderHandle m blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Map ReaderKey (ReaderHandle m blk))
cdbReaders  Map ReaderKey (ReaderHandle m blk)
forall k a. Map k a
Map.empty
      [ReaderHandle m blk] -> STM m [ReaderHandle m blk]
forall (m :: * -> *) a. Monad m => a -> m a
return [ReaderHandle m blk]
readerHandles
    (ReaderHandle m blk -> m ()) -> [ReaderHandle m blk] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ReaderHandle m blk -> m ()
forall (m :: * -> *) blk. ReaderHandle m blk -> m ()
rhClose [ReaderHandle m blk]
readerHandles