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

-- | Followers
module Ouroboros.Consensus.Storage.ChainDB.Impl.Follower (
    closeAllFollowers
  , newFollower
  , switchFork
  ) 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           Data.Maybe.Strict (StrictMaybe (..))

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 (..), ChainType (..), Follower (..), 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 follower with the given 'FollowerKey' still exists. If not,
-- throw a 'ClosedFollowerError'.
--
-- Otherwise, execute the given function on the 'ChainDbEnv'.
getFollower ::
     forall m blk r. (IOLike m, HasCallStack, HasHeader blk)
  => ChainDbHandle m blk
  -> FollowerKey
  -> (ChainDbEnv m blk -> m r)
  -> m r
getFollower :: ChainDbHandle m blk
-> FollowerKey -> (ChainDbEnv m blk -> m r) -> m r
getFollower (CDBHandle StrictTVar m (ChainDbState m blk)
varState) FollowerKey
followerKey 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 blk -> STM m (ChainDbEnv m blk)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ChainDbError blk -> STM m (ChainDbEnv m blk))
-> ChainDbError blk -> STM m (ChainDbEnv m blk)
forall a b. (a -> b) -> a -> b
$ PrettyCallStack -> ChainDbError blk
forall blk. PrettyCallStack -> ChainDbError blk
ClosedDBError @blk PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack
      ChainDbOpen ChainDbEnv m blk
env -> do
        Bool
followerOpen <- FollowerKey -> Map FollowerKey (FollowerHandle m blk) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FollowerKey
followerKey (Map FollowerKey (FollowerHandle m blk) -> Bool)
-> STM m (Map FollowerKey (FollowerHandle m blk)) -> STM m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
-> STM m (Map FollowerKey (FollowerHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers ChainDbEnv m blk
env)
        if Bool
followerOpen
          then ChainDbEnv m blk -> STM m (ChainDbEnv m blk)
forall (m :: * -> *) a. Monad m => a -> m a
return ChainDbEnv m blk
env
          else ChainDbError blk -> STM m (ChainDbEnv m blk)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ChainDbError blk -> STM m (ChainDbEnv m blk))
-> ChainDbError blk -> STM m (ChainDbEnv m blk)
forall a b. (a -> b) -> a -> b
$ ChainDbError blk
forall blk. ChainDbError blk
ClosedFollowerError @blk
    ChainDbEnv m blk -> m r
f ChainDbEnv m blk
env

-- | Variant 'of 'getFollower' for functions taking one argument.
getFollower1 ::
     forall m blk a r. (IOLike m, HasHeader blk)
  => ChainDbHandle m blk
  -> FollowerKey
  -> (ChainDbEnv m blk -> a -> m r)
  -> a -> m r
getFollower1 :: ChainDbHandle m blk
-> FollowerKey -> (ChainDbEnv m blk -> a -> m r) -> a -> m r
getFollower1 ChainDbHandle m blk
h FollowerKey
followerKey ChainDbEnv m blk -> a -> m r
f a
a = ChainDbHandle m blk
-> FollowerKey -> (ChainDbEnv m blk -> m r) -> m r
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk
-> FollowerKey -> (ChainDbEnv m blk -> m r) -> m r
getFollower ChainDbHandle m blk
h FollowerKey
followerKey (\ChainDbEnv m blk
env -> ChainDbEnv m blk -> a -> m r
f ChainDbEnv m blk
env a
a)

{-------------------------------------------------------------------------------
  Follower
-------------------------------------------------------------------------------}

newFollower ::
     forall m blk b.
     ( IOLike m
     , HasHeader blk
     , GetHeader blk
     , HasNestedContent Header blk
     , EncodeDiskDep (NestedCtxt Header) blk
     )
  => ChainDbHandle m blk
  -> ResourceRegistry m
  -> ChainType
  -> BlockComponent blk b
  -> m (Follower m blk b)
newFollower :: ChainDbHandle m blk
-> ResourceRegistry m
-> ChainType
-> BlockComponent blk b
-> m (Follower m blk b)
newFollower ChainDbHandle m blk
h ResourceRegistry m
registry ChainType
chainType BlockComponent blk b
blockComponent = ChainDbHandle m blk
-> (ChainDbEnv m blk -> m (Follower m blk b))
-> m (Follower m blk b)
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> m r) -> m r
getEnv ChainDbHandle m blk
h ((ChainDbEnv m blk -> m (Follower m blk b))
 -> m (Follower m blk b))
-> (ChainDbEnv m blk -> m (Follower m blk b))
-> m (Follower m blk b)
forall a b. (a -> b) -> a -> b
$ \CDB{Tracer m (LedgerDB' blk)
Tracer m (TraceEvent blk)
DiffTime
StrictTVar m (m ())
StrictTVar m (FutureBlocks m blk)
StrictTVar m (Map FollowerKey (FollowerHandle m blk))
StrictTVar m (Map IteratorKey (m ()))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (StrictMaybe (Header blk))
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m (TentativeState blk)
StrictTVar m FollowerKey
StrictTVar m IteratorKey
TopLevelConfig blk
StrictMVar m ()
VolatileDB m blk
ChunkInfo
ResourceRegistry m
ImmutableDB m blk
CheckInFuture m blk
LgrDB m blk
BlocksToAdd m blk
blk -> Bool
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks m blk)
cdbBlocksToAdd :: forall (m :: * -> *) blk. ChainDbEnv m blk -> BlocksToAdd m blk
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbCheckIntegrity :: forall (m :: * -> *) blk. ChainDbEnv m blk -> blk -> Bool
cdbChunkInfo :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChunkInfo
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbTraceLedger :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (LedgerDB' blk)
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
cdbCopyLock :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictMVar m ()
cdbNextFollowerKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m FollowerKey
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbTentativeHeader :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (StrictMaybe (Header blk))
cdbTentativeState :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (TentativeState blk)
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbFutureBlocks :: StrictTVar m (FutureBlocks m blk)
cdbBlocksToAdd :: BlocksToAdd m blk
cdbCheckInFuture :: CheckInFuture m blk
cdbCheckIntegrity :: blk -> Bool
cdbChunkInfo :: ChunkInfo
cdbKillBgThreads :: StrictTVar m (m ())
cdbGcInterval :: DiffTime
cdbGcDelay :: DiffTime
cdbRegistry :: ResourceRegistry m
cdbTraceLedger :: Tracer m (LedgerDB' blk)
cdbTracer :: Tracer m (TraceEvent blk)
cdbCopyLock :: StrictMVar m ()
cdbNextFollowerKey :: StrictTVar m FollowerKey
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
cdbTentativeState :: StrictTVar m (TentativeState blk)
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: LgrDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbImmutableDB :: ImmutableDB m blk
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
..} -> do
    -- The following operations don't need to be done in a single transaction
    FollowerKey
followerKey  <- STM m FollowerKey -> m FollowerKey
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m FollowerKey -> m FollowerKey)
-> STM m FollowerKey -> m FollowerKey
forall a b. (a -> b) -> a -> b
$ StrictTVar m FollowerKey
-> (FollowerKey -> (FollowerKey, FollowerKey)) -> STM m FollowerKey
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m FollowerKey
cdbNextFollowerKey ((FollowerKey -> (FollowerKey, FollowerKey)) -> STM m FollowerKey)
-> (FollowerKey -> (FollowerKey, FollowerKey)) -> STM m FollowerKey
forall a b. (a -> b) -> a -> b
$ \FollowerKey
r -> (FollowerKey
r, FollowerKey -> FollowerKey
forall a. Enum a => a -> a
succ FollowerKey
r)
    StrictTVar m (FollowerState m blk b)
varFollower <- FollowerState m blk b -> m (StrictTVar m (FollowerState m blk b))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO FollowerState m blk b
forall (m :: * -> *) blk b. FollowerState m blk b
FollowerInit
    let followerHandle :: FollowerHandle m blk
followerHandle = StrictTVar m (FollowerState m blk b) -> FollowerHandle m blk
mkFollowerHandle StrictTVar m (FollowerState m blk b)
varFollower
    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 FollowerKey (FollowerHandle m blk))
-> (Map FollowerKey (FollowerHandle m blk)
    -> Map FollowerKey (FollowerHandle m blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers ((Map FollowerKey (FollowerHandle m blk)
  -> Map FollowerKey (FollowerHandle m blk))
 -> STM m ())
-> (Map FollowerKey (FollowerHandle m blk)
    -> Map FollowerKey (FollowerHandle m blk))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ FollowerKey
-> FollowerHandle m blk
-> Map FollowerKey (FollowerHandle m blk)
-> Map FollowerKey (FollowerHandle m blk)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FollowerKey
followerKey FollowerHandle m blk
followerHandle
    let follower :: Follower m blk b
follower =
          ChainDbHandle m blk
-> FollowerKey
-> StrictTVar m (FollowerState m blk b)
-> ChainType
-> ResourceRegistry m
-> BlockComponent blk b
-> Follower m blk b
forall (m :: * -> *) blk b.
(IOLike m, HasHeader blk, GetHeader blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
ChainDbHandle m blk
-> FollowerKey
-> StrictTVar m (FollowerState m blk b)
-> ChainType
-> ResourceRegistry m
-> BlockComponent blk b
-> Follower m blk b
makeNewFollower ChainDbHandle m blk
h FollowerKey
followerKey StrictTVar m (FollowerState m blk b)
varFollower ChainType
chainType 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
$ TraceFollowerEvent blk -> TraceEvent blk
forall blk. TraceFollowerEvent blk -> TraceEvent blk
TraceFollowerEvent TraceFollowerEvent blk
forall blk. TraceFollowerEvent blk
NewFollower
    Follower m blk b -> m (Follower m blk b)
forall (m :: * -> *) a. Monad m => a -> m a
return Follower m blk b
follower
  where
    mkFollowerHandle :: StrictTVar m (FollowerState m blk b) -> FollowerHandle m blk
    mkFollowerHandle :: StrictTVar m (FollowerState m blk b) -> FollowerHandle m blk
mkFollowerHandle StrictTVar m (FollowerState m blk b)
varFollower = FollowerHandle :: forall (m :: * -> *) blk.
ChainType
-> (Point blk -> AnchoredFragment (Header blk) -> STM m ())
-> m ()
-> FollowerHandle m blk
FollowerHandle
      { fhChainType :: ChainType
fhChainType  = ChainType
chainType
      , fhClose :: m ()
fhClose      = do
          -- This is only called by 'closeAllFollowers'. We just release the
          -- resources. We don't check whether the Follower is still open.
          -- We don't have to remove the follower from the 'cdbFollowers',
          -- 'closeAllFollowers' will empty that map already.
          FollowerState m blk b
followerState <- STM m (FollowerState m blk b) -> m (FollowerState m blk b)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (FollowerState m blk b) -> m (FollowerState m blk b))
-> STM m (FollowerState m blk b) -> m (FollowerState m blk b)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (FollowerState m blk b)
-> STM m (FollowerState m blk b)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FollowerState m blk b)
varFollower
          FollowerState m blk b -> m ()
forall (m :: * -> *) blk b.
MonadCatch m =>
FollowerState m blk b -> m ()
closeFollowerState FollowerState m blk b
followerState
      , fhSwitchFork :: Point blk -> AnchoredFragment (Header blk) -> STM m ()
fhSwitchFork = \Point blk
ipoint AnchoredFragment (Header blk)
newChain -> StrictTVar m (FollowerState m blk b)
-> (FollowerState m blk b -> FollowerState m blk b) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (FollowerState m blk b)
varFollower ((FollowerState m blk b -> FollowerState m blk b) -> STM m ())
-> (FollowerState m blk b -> FollowerState m blk b) -> STM m ()
forall a b. (a -> b) -> a -> b
$
          Point blk
-> AnchoredFragment (Header blk)
-> FollowerState m blk b
-> FollowerState m blk b
forall (m :: * -> *) blk b.
(HasHeader blk, HasHeader (Header blk)) =>
Point blk
-> AnchoredFragment (Header blk)
-> FollowerState m blk b
-> FollowerState m blk b
switchFork Point blk
ipoint AnchoredFragment (Header blk)
newChain
      }

makeNewFollower ::
     forall m blk b.
     ( IOLike m
     , HasHeader blk
     , GetHeader blk
     , HasNestedContent Header blk
     , EncodeDiskDep (NestedCtxt Header) blk
     )
  => ChainDbHandle m blk
  -> FollowerKey
  -> StrictTVar m (FollowerState m blk b)
  -> ChainType
  -> ResourceRegistry m
  -> BlockComponent blk b
  -> Follower m blk b
makeNewFollower :: ChainDbHandle m blk
-> FollowerKey
-> StrictTVar m (FollowerState m blk b)
-> ChainType
-> ResourceRegistry m
-> BlockComponent blk b
-> Follower m blk b
makeNewFollower ChainDbHandle m blk
h FollowerKey
followerKey StrictTVar m (FollowerState m blk b)
varFollower ChainType
chainType ResourceRegistry m
registry BlockComponent blk b
blockComponent = Follower :: forall (m :: * -> *) blk a.
m (Maybe (ChainUpdate blk a))
-> m (ChainUpdate blk a)
-> ([Point blk] -> m (Maybe (Point blk)))
-> m ()
-> Follower m blk a
Follower {m (Maybe (ChainUpdate blk b))
m ()
m (ChainUpdate blk b)
[Point blk] -> m (Maybe (Point blk))
followerClose :: m ()
followerForward :: [Point blk] -> m (Maybe (Point blk))
followerInstructionBlocking :: m (ChainUpdate blk b)
followerInstruction :: m (Maybe (ChainUpdate blk b))
followerClose :: m ()
followerForward :: [Point blk] -> m (Maybe (Point blk))
followerInstructionBlocking :: m (ChainUpdate blk b)
followerInstruction :: m (Maybe (ChainUpdate blk b))
..}
  where
    followerInstruction :: m (Maybe (ChainUpdate blk b))
    followerInstruction :: m (Maybe (ChainUpdate blk b))
followerInstruction = ChainDbHandle m blk
-> FollowerKey
-> (ChainDbEnv m blk -> m (Maybe (ChainUpdate blk b)))
-> m (Maybe (ChainUpdate blk b))
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk
-> FollowerKey -> (ChainDbEnv m blk -> m r) -> m r
getFollower ChainDbHandle m blk
h FollowerKey
followerKey ((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 (FollowerState m blk b)
-> ChainType
-> 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 (FollowerState m blk b)
-> ChainType
-> 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 (FollowerState m blk b)
varFollower ChainType
chainType BlockComponent blk b
blockComponent STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (Maybe (ChainUpdate blk (Header blk)))
forall a. a -> a
id

    followerInstructionBlocking :: m (ChainUpdate blk b)
    followerInstructionBlocking :: m (ChainUpdate blk b)
followerInstructionBlocking = (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
-> FollowerKey
-> (ChainDbEnv m blk -> m (Identity (ChainUpdate blk b)))
-> m (Identity (ChainUpdate blk b))
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk
-> FollowerKey -> (ChainDbEnv m blk -> m r) -> m r
getFollower ChainDbHandle m blk
h FollowerKey
followerKey ((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 (FollowerState m blk b)
-> ChainType
-> 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 (FollowerState m blk b)
-> ChainType
-> 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 (FollowerState m blk b)
varFollower ChainType
chainType 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 (m :: * -> *) a. MonadSTM m => STM m (Maybe a) -> STM m a
blockUntilJust)

    followerForward :: [Point blk] -> m (Maybe (Point blk))
    followerForward :: [Point blk] -> m (Maybe (Point blk))
followerForward = ChainDbHandle m blk
-> FollowerKey
-> (ChainDbEnv m blk -> [Point blk] -> m (Maybe (Point blk)))
-> [Point blk]
-> m (Maybe (Point blk))
forall (m :: * -> *) blk a r.
(IOLike m, HasHeader blk) =>
ChainDbHandle m blk
-> FollowerKey -> (ChainDbEnv m blk -> a -> m r) -> a -> m r
getFollower1 ChainDbHandle m blk
h FollowerKey
followerKey ((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 (FollowerState 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 (FollowerState m blk b)
-> BlockComponent blk b
-> ChainDbEnv m blk
-> [Point blk]
-> m (Maybe (Point blk))
forward ResourceRegistry m
registry StrictTVar m (FollowerState m blk b)
varFollower BlockComponent blk b
blockComponent

    followerClose :: m ()
    followerClose :: m ()
followerClose = ChainDbHandle m blk -> (ChainDbEnv m blk -> m ()) -> m ()
forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
ChainDbHandle m blk -> (ChainDbEnv m blk -> m r) -> m r
getEnv ChainDbHandle m blk
h ((ChainDbEnv m blk -> m ()) -> m ())
-> (ChainDbEnv m blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ FollowerKey
-> StrictTVar m (FollowerState m blk b) -> ChainDbEnv m blk -> m ()
forall (m :: * -> *) blk b.
IOLike m =>
FollowerKey
-> StrictTVar m (FollowerState m blk b) -> ChainDbEnv m blk -> m ()
close FollowerKey
followerKey StrictTVar m (FollowerState m blk b)
varFollower

-- | Implementation of 'followerClose'.
--
-- To be called using 'getEnv' to make sure the ChainDB is still open.
--
-- Idempotent: the follower doesn't have to be open.
--
-- Unlike 'closeAllFollowers', this is meant to be called by the user of the
-- ChainDB.Follower.
close ::
     forall m blk b. IOLike m
  => FollowerKey
  -> StrictTVar m (FollowerState m blk b)
  -> ChainDbEnv m blk
  -> m ()
close :: FollowerKey
-> StrictTVar m (FollowerState m blk b) -> ChainDbEnv m blk -> m ()
close FollowerKey
followerKey StrictTVar m (FollowerState m blk b)
varFollower CDB { StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers } = do
    -- If the FollowerKey is not present in the map, the Follower 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 FollowerKey (FollowerHandle m blk))
-> (Map FollowerKey (FollowerHandle m blk)
    -> Map FollowerKey (FollowerHandle m blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers ((Map FollowerKey (FollowerHandle m blk)
  -> Map FollowerKey (FollowerHandle m blk))
 -> STM m ())
-> (Map FollowerKey (FollowerHandle m blk)
    -> Map FollowerKey (FollowerHandle m blk))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ FollowerKey
-> Map FollowerKey (FollowerHandle m blk)
-> Map FollowerKey (FollowerHandle m blk)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FollowerKey
followerKey
    FollowerState m blk b
followerState <- STM m (FollowerState m blk b) -> m (FollowerState m blk b)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (FollowerState m blk b) -> m (FollowerState m blk b))
-> STM m (FollowerState m blk b) -> m (FollowerState m blk b)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (FollowerState m blk b)
-> STM m (FollowerState m blk b)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FollowerState m blk b)
varFollower
    FollowerState m blk b -> m ()
forall (m :: * -> *) blk b.
MonadCatch m =>
FollowerState m blk b -> m ()
closeFollowerState FollowerState m blk b
followerState

-- | Close the given 'FollowerState' by closing any 'ImmutableDB.Iterator' it
-- might contain.
closeFollowerState :: MonadCatch m => FollowerState m blk b -> m ()
closeFollowerState :: FollowerState m blk b -> m ()
closeFollowerState = \case
     FollowerState m blk b
FollowerInit                  -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     FollowerInMem FollowerRollState blk
_               -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     -- IMPORTANT: the main reason we're closing followers: to close this open
     -- iterator, which contains a reference to a file handle.
     FollowerInImmutableDB FollowerRollState 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 'followerInstruction' and 'followerInstructionBlocking'.
--
-- The type @f@ will be instantiated to:
--
-- * 'Maybe' in case of 'followerInstruction'.
-- * 'Identity' in case of 'followerInstructionBlocking'.
--
-- The returned 'ChainUpdate' contains a 'b', as defined by 'BlockComponent'.
--
-- When in the 'FollowerInImmutableDB' state, we never have to block, as we can
-- just stream the next block/header from the ImmutableDB.
--
-- When in the 'FollowerInMem' 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 (FollowerState m blk b)
  -> ChainType
  -> 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 (FollowerState m blk b)
-> ChainType
-> 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 (FollowerState m blk b)
varFollower ChainType
chainType 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)
DiffTime
StrictTVar m (m ())
StrictTVar m (FutureBlocks m blk)
StrictTVar m (Map FollowerKey (FollowerHandle m blk))
StrictTVar m (Map IteratorKey (m ()))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (StrictMaybe (Header blk))
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m (TentativeState blk)
StrictTVar m FollowerKey
StrictTVar m IteratorKey
TopLevelConfig blk
StrictMVar m ()
VolatileDB m blk
ChunkInfo
ResourceRegistry m
ImmutableDB m blk
CheckInFuture m blk
LgrDB m blk
BlocksToAdd m blk
blk -> Bool
cdbFutureBlocks :: StrictTVar m (FutureBlocks m blk)
cdbBlocksToAdd :: BlocksToAdd m blk
cdbCheckInFuture :: CheckInFuture m blk
cdbCheckIntegrity :: blk -> Bool
cdbChunkInfo :: ChunkInfo
cdbKillBgThreads :: StrictTVar m (m ())
cdbGcInterval :: DiffTime
cdbGcDelay :: DiffTime
cdbRegistry :: ResourceRegistry m
cdbTraceLedger :: Tracer m (LedgerDB' blk)
cdbTracer :: Tracer m (TraceEvent blk)
cdbCopyLock :: StrictMVar m ()
cdbNextFollowerKey :: StrictTVar m FollowerKey
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
cdbTentativeState :: StrictTVar m (TentativeState blk)
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: LgrDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbImmutableDB :: ImmutableDB m blk
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks m blk)
cdbBlocksToAdd :: forall (m :: * -> *) blk. ChainDbEnv m blk -> BlocksToAdd m blk
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbCheckIntegrity :: forall (m :: * -> *) blk. ChainDbEnv m blk -> blk -> Bool
cdbChunkInfo :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChunkInfo
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbTraceLedger :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (LedgerDB' blk)
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
cdbCopyLock :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictMVar m ()
cdbNextFollowerKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m FollowerKey
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbTentativeHeader :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (StrictMaybe (Header blk))
cdbTentativeState :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (TentativeState blk)
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
..} = do
    -- In one transaction: check in which state we are, if in the
    -- @FollowerInMem@ state, just call 'instructionSTM', otherwise,
    -- return the contents of the 'FollowerInImmutableDB' state.
    Either
  (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
  (f (ChainUpdate blk (Header blk)))
inImmutableDBOrRes <- STM
  m
  (Either
     (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk))))
-> m (Either
        (FollowerRollState 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
      (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
      (f (ChainUpdate blk (Header blk))))
 -> m (Either
         (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
         (f (ChainUpdate blk (Header blk)))))
-> STM
     m
     (Either
        (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
-> m (Either
        (FollowerRollState 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 <- STM m (AnchoredFragment (Header blk))
getCurrentChainByType
      StrictTVar m (FollowerState m blk b)
-> STM m (FollowerState m blk b)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FollowerState m blk b)
varFollower STM m (FollowerState m blk b)
-> (FollowerState m blk b
    -> STM
         m
         (Either
            (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
            (f (ChainUpdate blk (Header blk)))))
-> STM
     m
     (Either
        (FollowerRollState 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.
        FollowerState m blk b
FollowerInit
          -> Either
  (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
  (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
   (f (ChainUpdate blk (Header blk)))
 -> STM
      m
      (Either
         (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
         (f (ChainUpdate blk (Header blk)))))
-> Either
     (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall a b. (a -> b) -> a -> b
$ (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
-> Either
     (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
forall a b. a -> Either a b
Left (Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState blk
RollBackTo Point blk
forall block. Point block
GenesisPoint, Maybe (Iterator m blk (Point blk, b))
forall a. Maybe a
Nothing)
        FollowerInImmutableDB FollowerRollState blk
rollState Iterator m blk (Point blk, b)
immIt
          -> Either
  (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
  (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
   (f (ChainUpdate blk (Header blk)))
 -> STM
      m
      (Either
         (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
         (f (ChainUpdate blk (Header blk)))))
-> Either
     (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall a b. (a -> b) -> a -> b
$ (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
-> Either
     (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
forall a b. a -> Either a b
Left (FollowerRollState 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)

        FollowerInMem FollowerRollState 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 (FollowerRollState blk -> Point blk
forall blk. FollowerRollState blk -> Point blk
followerRollStatePoint FollowerRollState blk
rollState)) AnchoredFragment (Header blk)
curChain
            -- The point is still in the current chain fragment
          -> (f (ChainUpdate blk (Header blk))
 -> Either
      (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
      (f (ChainUpdate blk (Header blk))))
-> STM m (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (FollowerRollState 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
     (FollowerRollState 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
         (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
         (f (ChainUpdate blk (Header blk)))))
-> STM m (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (FollowerRollState 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
$
               FollowerRollState blk
-> AnchoredFragment (Header blk)
-> (FollowerRollState blk -> STM m ())
-> STM m (Maybe (ChainUpdate blk (Header blk)))
forall (m :: * -> *) blk.
(MonadSTM m, HasHeader (Header blk)) =>
FollowerRollState blk
-> AnchoredFragment (Header blk)
-> (FollowerRollState blk -> STM m ())
-> STM m (Maybe (ChainUpdate blk (Header blk)))
instructionSTM
                 FollowerRollState blk
rollState
                 AnchoredFragment (Header blk)
curChain
                 (StrictTVar m (FollowerState m blk b)
-> FollowerState m blk b -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FollowerState m blk b)
varFollower (FollowerState m blk b -> STM m ())
-> (FollowerRollState blk -> FollowerState m blk b)
-> FollowerRollState blk
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FollowerRollState blk -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk -> FollowerState m blk b
FollowerInMem)
          | 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
  (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
  (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
   (f (ChainUpdate blk (Header blk)))
 -> STM
      m
      (Either
         (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
         (f (ChainUpdate blk (Header blk)))))
-> Either
     (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
-> STM
     m
     (Either
        (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
        (f (ChainUpdate blk (Header blk))))
forall a b. (a -> b) -> a -> b
$ (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
-> Either
     (FollowerRollState blk, Maybe (Iterator m blk (Point blk, b)))
     (f (ChainUpdate blk (Header blk)))
forall a b. a -> Either a b
Left (FollowerRollState blk
rollState, Maybe (Iterator m blk (Point blk, b))
forall a. Maybe a
Nothing)
    case Either
  (FollowerRollState 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 'FollowerInMem' 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 'FollowerInImmutableDB' state or we need to switch to it.
      Left (FollowerRollState 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 'FollowerInMem' state but have to switch to the
          -- 'FollowerInImmutableDB' state.
          Maybe (Iterator m blk (Point blk, b))
Nothing    -> do
            TraceFollowerEvent blk -> m ()
trace (TraceFollowerEvent blk -> m ()) -> TraceFollowerEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ FollowerRollState blk -> TraceFollowerEvent blk
forall blk. FollowerRollState blk -> TraceFollowerEvent blk
FollowerNoLongerInMem FollowerRollState 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)
              (FollowerRollState blk -> Point blk
forall blk. FollowerRollState blk -> Point blk
followerRollStatePoint FollowerRollState blk
rollState)
        case FollowerRollState 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 followerState' :: FollowerState m blk b
followerState' = FollowerRollState blk
-> Iterator m blk (Point blk, b) -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk
-> Iterator m blk (Point blk, b) -> FollowerState m blk b
FollowerInImmutableDB (Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState 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 (FollowerState m blk b)
-> FollowerState m blk b -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FollowerState m blk b)
varFollower FollowerState m blk b
followerState'
            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 :: TraceFollowerEvent blk -> m ()
trace = Tracer m (TraceFollowerEvent blk) -> TraceFollowerEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith ((TraceFollowerEvent blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceFollowerEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap TraceFollowerEvent blk -> TraceEvent blk
forall blk. TraceFollowerEvent blk -> TraceEvent blk
TraceFollowerEvent Tracer m (TraceEvent blk)
cdbTracer)

    getCurrentChainByType :: STM m (AnchoredFragment (Header blk))
getCurrentChainByType = 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
        case ChainType
chainType of
          ChainType
SelectedChain  -> AnchoredFragment (Header blk)
-> STM m (AnchoredFragment (Header blk))
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnchoredFragment (Header blk)
curChain
          ChainType
TentativeChain -> StrictTVar m (StrictMaybe (Header blk))
-> STM m (StrictMaybe (Header blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (StrictMaybe (Header blk))
cdbTentativeHeader STM m (StrictMaybe (Header blk))
-> (StrictMaybe (Header blk) -> AnchoredFragment (Header blk))
-> STM m (AnchoredFragment (Header blk))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            SJust Header blk
hdr -> AnchoredFragment (Header blk)
curChain AnchoredFragment (Header blk)
-> Header blk -> AnchoredFragment (Header blk)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
AF.:> Header blk
hdr
            StrictMaybe (Header blk)
SNothing  -> AnchoredFragment (Header blk)
curChain

    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 followerState' :: FollowerState m blk b
followerState' = FollowerRollState blk
-> Iterator m blk (Point blk, b) -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk
-> Iterator m blk (Point blk, b) -> FollowerState m blk b
FollowerInImmutableDB (Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState 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 (FollowerState m blk b)
-> FollowerState m blk b -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FollowerState m blk b)
varFollower FollowerState m blk b
followerState'
        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]
"follower 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
            TraceFollowerEvent blk -> m ()
trace (TraceFollowerEvent blk -> m ()) -> TraceFollowerEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> WithOrigin SlotNo -> TraceFollowerEvent blk
forall blk.
Point blk -> WithOrigin SlotNo -> TraceFollowerEvent blk
FollowerSwitchToMem 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 <- STM m (AnchoredFragment (Header blk))
getCurrentChainByType
              FollowerRollState blk
-> AnchoredFragment (Header blk)
-> (FollowerRollState blk -> STM m ())
-> STM m (Maybe (ChainUpdate blk (Header blk)))
forall (m :: * -> *) blk.
(MonadSTM m, HasHeader (Header blk)) =>
FollowerRollState blk
-> AnchoredFragment (Header blk)
-> (FollowerRollState blk -> STM m ())
-> STM m (Maybe (ChainUpdate blk (Header blk)))
instructionSTM
                (Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState blk
RollForwardFrom Point blk
pt)
                AnchoredFragment (Header blk)
curChain
                (StrictTVar m (FollowerState m blk b)
-> FollowerState m blk b -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FollowerState m blk b)
varFollower (FollowerState m blk b -> STM m ())
-> (FollowerRollState blk -> FollowerState m blk b)
-> FollowerRollState blk
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FollowerRollState blk -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk -> FollowerState m blk b
FollowerInMem)
            -- 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
            TraceFollowerEvent blk -> m ()
trace (TraceFollowerEvent blk -> m ()) -> TraceFollowerEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> WithOrigin SlotNo -> TraceFollowerEvent blk
forall blk.
Point blk -> WithOrigin SlotNo -> TraceFollowerEvent blk
FollowerNewImmIterator 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

-- | 'followerInstruction' for when the follower is in the 'FollowerInMem' state.
instructionSTM ::
     forall m blk. (MonadSTM m, HasHeader (Header blk))
  => FollowerRollState blk
     -- ^ The current 'FollowerRollState' of the follower
  -> AnchoredFragment (Header blk)
     -- ^ The current chain fragment
  -> (FollowerRollState blk -> STM m ())
     -- ^ How to save the updated 'FollowerRollState'
  -> STM m (Maybe (ChainUpdate blk (Header blk)))
instructionSTM :: FollowerRollState blk
-> AnchoredFragment (Header blk)
-> (FollowerRollState blk -> STM m ())
-> STM m (Maybe (ChainUpdate blk (Header blk)))
instructionSTM FollowerRollState blk
rollState AnchoredFragment (Header blk)
curChain FollowerRollState blk -> STM m ()
saveRollState =
    Bool
-> STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (Maybe (ChainUpdate blk (Header blk)))
forall a. HasCallStack => Bool -> a -> a
assert (AnchoredFragment (Header blk) -> Bool
invariant AnchoredFragment (Header blk)
curChain) (STM m (Maybe (ChainUpdate blk (Header blk)))
 -> STM m (Maybe (ChainUpdate blk (Header blk))))
-> STM m (Maybe (ChainUpdate blk (Header blk)))
-> STM m (Maybe (ChainUpdate blk (Header blk)))
forall a b. (a -> b) -> a -> b
$ case FollowerRollState 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 follower is at the head
          Maybe (Header blk)
Nothing  -> Maybe (ChainUpdate blk (Header blk))
-> STM m (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
            FollowerRollState blk -> STM m ()
saveRollState (FollowerRollState blk -> STM m ())
-> FollowerRollState blk -> STM m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState blk
RollForwardFrom (Point blk -> FollowerRollState blk)
-> Point blk -> FollowerRollState 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 m (Maybe (ChainUpdate blk (Header blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ChainUpdate blk (Header blk))
 -> STM m (Maybe (ChainUpdate blk (Header blk))))
-> Maybe (ChainUpdate blk (Header blk))
-> STM m (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
        FollowerRollState blk -> STM m ()
saveRollState (FollowerRollState blk -> STM m ())
-> FollowerRollState blk -> STM m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState blk
RollForwardFrom Point blk
pt
        Maybe (ChainUpdate blk (Header blk))
-> STM m (Maybe (ChainUpdate blk (Header blk)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ChainUpdate blk (Header blk))
 -> STM m (Maybe (ChainUpdate blk (Header blk))))
-> Maybe (ChainUpdate blk (Header blk))
-> STM m (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 (FollowerRollState blk -> Point blk
forall blk. FollowerRollState blk -> Point blk
followerRollStatePoint FollowerRollState blk
rollState))

forward ::
     forall m blk b.
     ( IOLike m
     , HasCallStack
     , HasHeader blk
     , HasHeader (Header blk)
     )
  => ResourceRegistry m
  -> StrictTVar m (FollowerState m blk b)
  -> BlockComponent blk b
  -> ChainDbEnv m blk
  -> [Point blk]
  -> m (Maybe (Point blk))
forward :: ResourceRegistry m
-> StrictTVar m (FollowerState m blk b)
-> BlockComponent blk b
-> ChainDbEnv m blk
-> [Point blk]
-> m (Maybe (Point blk))
forward ResourceRegistry m
registry StrictTVar m (FollowerState m blk b)
varFollower BlockComponent blk b
blockComponent CDB{Tracer m (LedgerDB' blk)
Tracer m (TraceEvent blk)
DiffTime
StrictTVar m (m ())
StrictTVar m (FutureBlocks m blk)
StrictTVar m (Map FollowerKey (FollowerHandle m blk))
StrictTVar m (Map IteratorKey (m ()))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (StrictMaybe (Header blk))
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m (TentativeState blk)
StrictTVar m FollowerKey
StrictTVar m IteratorKey
TopLevelConfig blk
StrictMVar m ()
VolatileDB m blk
ChunkInfo
ResourceRegistry m
ImmutableDB m blk
CheckInFuture m blk
LgrDB m blk
BlocksToAdd m blk
blk -> Bool
cdbFutureBlocks :: StrictTVar m (FutureBlocks m blk)
cdbBlocksToAdd :: BlocksToAdd m blk
cdbCheckInFuture :: CheckInFuture m blk
cdbCheckIntegrity :: blk -> Bool
cdbChunkInfo :: ChunkInfo
cdbKillBgThreads :: StrictTVar m (m ())
cdbGcInterval :: DiffTime
cdbGcDelay :: DiffTime
cdbRegistry :: ResourceRegistry m
cdbTraceLedger :: Tracer m (LedgerDB' blk)
cdbTracer :: Tracer m (TraceEvent blk)
cdbCopyLock :: StrictMVar m ()
cdbNextFollowerKey :: StrictTVar m FollowerKey
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
cdbTentativeState :: StrictTVar m (TentativeState blk)
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: LgrDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbImmutableDB :: ImmutableDB m blk
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks m blk)
cdbBlocksToAdd :: forall (m :: * -> *) blk. ChainDbEnv m blk -> BlocksToAdd m blk
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbCheckIntegrity :: forall (m :: * -> *) blk. ChainDbEnv m blk -> blk -> Bool
cdbChunkInfo :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChunkInfo
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbTraceLedger :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (LedgerDB' blk)
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
cdbCopyLock :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictMVar m ()
cdbNextFollowerKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m FollowerKey
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbTentativeHeader :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (StrictMaybe (Header blk))
cdbTentativeState :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (TentativeState blk)
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
..} = \[Point blk]
pts -> do
    -- NOTE: we use 'cdbChain' instead of 'Query.getCurrentChain', which only
    -- returns the last @k@ headers, because we need to also see the headers
    -- that happen to have not yet been copied over to the ImmutableDB.
    m (m (Maybe (Point blk))) -> m (Maybe (Point blk))
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m (Maybe (Point blk))) -> m (Maybe (Point blk)))
-> m (m (Maybe (Point blk))) -> m (Maybe (Point blk))
forall a b. (a -> b) -> a -> b
$ STM m (m (Maybe (Point blk))) -> m (m (Maybe (Point blk)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m (Maybe (Point blk))) -> m (m (Maybe (Point blk))))
-> STM m (m (Maybe (Point blk))) -> m (m (Maybe (Point blk)))
forall a b. (a -> b) -> a -> b
$
      HasCallStack =>
AnchoredFragment (Header blk)
-> FollowerState m blk b
-> WithOrigin SlotNo
-> [Point blk]
-> m (Maybe (Point blk))
AnchoredFragment (Header blk)
-> FollowerState m blk b
-> WithOrigin SlotNo
-> [Point blk]
-> m (Maybe (Point blk))
findFirstPointOnChain
        (AnchoredFragment (Header blk)
 -> FollowerState m blk b
 -> WithOrigin SlotNo
 -> [Point blk]
 -> m (Maybe (Point blk)))
-> STM m (AnchoredFragment (Header blk))
-> STM
     m
     (FollowerState m blk b
      -> WithOrigin SlotNo -> [Point blk] -> m (Maybe (Point blk)))
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
  (FollowerState m blk b
   -> WithOrigin SlotNo -> [Point blk] -> m (Maybe (Point blk)))
-> STM m (FollowerState m blk b)
-> STM
     m (WithOrigin SlotNo -> [Point blk] -> m (Maybe (Point blk)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrictTVar m (FollowerState m blk b)
-> STM m (FollowerState m blk b)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (FollowerState m blk b)
varFollower
        STM m (WithOrigin SlotNo -> [Point blk] -> m (Maybe (Point blk)))
-> STM m (WithOrigin SlotNo)
-> STM m ([Point blk] -> m (Maybe (Point blk)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f 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
        STM m ([Point blk] -> m (Maybe (Point blk)))
-> STM m [Point blk] -> STM m (m (Maybe (Point blk)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Point blk] -> STM m [Point blk]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Point blk]
pts
  where
    findFirstPointOnChain ::
         HasCallStack
      => AnchoredFragment (Header blk)
      -> FollowerState m blk b
      -> WithOrigin SlotNo
      -> [Point blk]
      -> m (Maybe (Point blk))
    findFirstPointOnChain :: AnchoredFragment (Header blk)
-> FollowerState m blk b
-> WithOrigin SlotNo
-> [Point blk]
-> m (Maybe (Point blk))
findFirstPointOnChain AnchoredFragment (Header blk)
curChain FollowerState m blk b
followerState 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.
          FollowerState m blk b -> m ()
updateState (FollowerState m blk b -> m ()) -> FollowerState m blk b -> m ()
forall a b. (a -> b) -> a -> b
$ FollowerRollState blk -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk -> FollowerState m blk b
FollowerInMem (FollowerRollState blk -> FollowerState m blk b)
-> FollowerRollState blk -> FollowerState m blk b
forall a b. (a -> b) -> a -> b
$ Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState 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 follower.
        -> case FollowerState m blk b
followerState of
            FollowerState m blk b
FollowerInit
              | Point blk
pt Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
forall block. Point block
GenesisPoint
              -- The 'FollowerInit' 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

            FollowerInImmutableDB FollowerRollState blk
rollState Iterator m blk (Point blk, b)
immIt
              | FollowerRollState blk
rollState FollowerRollState blk -> FollowerRollState blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState 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

              | FollowerRollState blk
rollState FollowerRollState blk -> FollowerRollState blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState 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 (FollowerState m blk b)
-> FollowerState m blk b -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (FollowerState m blk b)
varFollower (FollowerState m blk b -> STM m ())
-> FollowerState m blk b -> STM m ()
forall a b. (a -> b) -> a -> b
$
                  FollowerRollState blk
-> Iterator m blk (Point blk, b) -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk
-> Iterator m blk (Point blk, b) -> FollowerState m blk b
FollowerInImmutableDB (Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState 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

            FollowerState 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
                FollowerState m blk b -> m ()
updateState FollowerState m blk b
forall (m :: * -> *) blk b. FollowerState m blk b
FollowerInit
                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
                  FollowerState m blk b -> m ()
updateState (FollowerState m blk b -> m ()) -> FollowerState m blk b -> m ()
forall a b. (a -> b) -> a -> b
$ FollowerRollState blk
-> Iterator m blk (Point blk, b) -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk
-> Iterator m blk (Point blk, b) -> FollowerState m blk b
FollowerInImmutableDB (Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState 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)
-> FollowerState m blk b
-> WithOrigin SlotNo
-> [Point blk]
-> m (Maybe (Point blk))
AnchoredFragment (Header blk)
-> FollowerState m blk b
-> WithOrigin SlotNo
-> [Point blk]
-> m (Maybe (Point blk))
findFirstPointOnChain AnchoredFragment (Header blk)
curChain FollowerState m blk b
followerState WithOrigin SlotNo
slotNoAtImmutableDBTip [Point blk]
pts

    -- | Update the state of the follower to the given state. If the current
    -- state is 'FollowerInImmutableDB', close the ImmutableDB iterator to avoid
    -- leaking the file handles.
    updateState :: FollowerState m blk b -> m ()
    updateState :: FollowerState m blk b -> m ()
updateState FollowerState m blk b
newFollowerState = 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 (FollowerState m blk b)
-> (FollowerState m blk b -> (m (), FollowerState m blk b))
-> STM m (m ())
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m (FollowerState m blk b)
varFollower ((FollowerState m blk b -> (m (), FollowerState m blk b))
 -> STM m (m ()))
-> (FollowerState m blk b -> (m (), FollowerState m blk b))
-> STM m (m ())
forall a b. (a -> b) -> a -> b
$ \FollowerState m blk b
followerState ->
        (, FollowerState m blk b
newFollowerState) (m () -> (m (), FollowerState m blk b))
-> m () -> (m (), FollowerState m blk b)
forall a b. (a -> b) -> a -> b
$ case FollowerState m blk b
followerState of
          -- Return a continuation (that we'll 'join') that closes the
          -- previous iterator.
          FollowerInImmutableDB FollowerRollState 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
          FollowerState m blk b
FollowerInit                  -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          FollowerInMem FollowerRollState blk
_               -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Update the given 'FollowerState' 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
  -> FollowerState m blk b -> FollowerState m blk b
switchFork :: Point blk
-> AnchoredFragment (Header blk)
-> FollowerState m blk b
-> FollowerState m blk b
switchFork Point blk
ipoint AnchoredFragment (Header blk)
newChain FollowerState m blk b
followerState =
    Bool -> FollowerState m blk b -> FollowerState 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) (FollowerState m blk b -> FollowerState m blk b)
-> FollowerState m blk b -> FollowerState m blk b
forall a b. (a -> b) -> a -> b
$
      case FollowerState m blk b
followerState of
        -- If the follower is still in the initial state, switching to a fork
        -- won't affect it.
        FollowerState m blk b
FollowerInit             -> FollowerState m blk b
followerState
        -- If the follower is still reading from the ImmutableDB, switching to a
        -- fork won't affect it.
        FollowerInImmutableDB {} -> FollowerState m blk b
followerState
        FollowerInMem FollowerRollState blk
rollState  ->
            case Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
followerPoint 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 follower point is more recent than the intersection point,
              -- we have to roll back the follower to the intersection point.
              Ordering
GT -> FollowerRollState blk -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk -> FollowerState m blk b
FollowerInMem (FollowerRollState blk -> FollowerState m blk b)
-> FollowerRollState blk -> FollowerState m blk b
forall a b. (a -> b) -> a -> b
$ Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState blk
RollBackTo Point blk
ipoint

              -- The follower 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
followerPoint 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.
                -> FollowerState m blk b
followerState
                | 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
followerPoint) 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 follower point is the intersection
                  -- point. It must be that the follower point is an EBB and
                  -- that the intersection point is a regular block in the
                  -- same slot. As the follower point is older than the
                  -- intersection point, no rollback is needed.
                -> FollowerState m blk b
followerState
                | Bool
otherwise
                  -- Either the intersection point is the EBB before the
                  -- follower 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 follower 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.
                -> FollowerRollState blk -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk -> FollowerState m blk b
FollowerInMem (FollowerRollState blk -> FollowerState m blk b)
-> FollowerRollState blk -> FollowerState m blk b
forall a b. (a -> b) -> a -> b
$ Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState blk
RollBackTo Point blk
ipoint

              -- The follower point is older than the intersection point, so we
              -- can keep rolling forward. Note that this does not mean the
              -- follower 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 'FollowerInImmutableDB' state.
              Ordering
LT -> FollowerState m blk b
followerState
          where
            followerPoint :: Point blk
followerPoint = FollowerRollState blk -> Point blk
forall blk. FollowerRollState blk -> Point blk
followerRollStatePoint FollowerRollState blk
rollState

-- | Close all open block and header 'Follower's.
closeAllFollowers ::
     IOLike m
  => ChainDbEnv m blk
  -> m ()
closeAllFollowers :: ChainDbEnv m blk -> m ()
closeAllFollowers CDB{Tracer m (LedgerDB' blk)
Tracer m (TraceEvent blk)
DiffTime
StrictTVar m (m ())
StrictTVar m (FutureBlocks m blk)
StrictTVar m (Map FollowerKey (FollowerHandle m blk))
StrictTVar m (Map IteratorKey (m ()))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (StrictMaybe (Header blk))
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m (TentativeState blk)
StrictTVar m FollowerKey
StrictTVar m IteratorKey
TopLevelConfig blk
StrictMVar m ()
VolatileDB m blk
ChunkInfo
ResourceRegistry m
ImmutableDB m blk
CheckInFuture m blk
LgrDB m blk
BlocksToAdd m blk
blk -> Bool
cdbFutureBlocks :: StrictTVar m (FutureBlocks m blk)
cdbBlocksToAdd :: BlocksToAdd m blk
cdbCheckInFuture :: CheckInFuture m blk
cdbCheckIntegrity :: blk -> Bool
cdbChunkInfo :: ChunkInfo
cdbKillBgThreads :: StrictTVar m (m ())
cdbGcInterval :: DiffTime
cdbGcDelay :: DiffTime
cdbRegistry :: ResourceRegistry m
cdbTraceLedger :: Tracer m (LedgerDB' blk)
cdbTracer :: Tracer m (TraceEvent blk)
cdbCopyLock :: StrictMVar m ()
cdbNextFollowerKey :: StrictTVar m FollowerKey
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
cdbTentativeState :: StrictTVar m (TentativeState blk)
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: LgrDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbImmutableDB :: ImmutableDB m blk
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks m blk)
cdbBlocksToAdd :: forall (m :: * -> *) blk. ChainDbEnv m blk -> BlocksToAdd m blk
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbCheckIntegrity :: forall (m :: * -> *) blk. ChainDbEnv m blk -> blk -> Bool
cdbChunkInfo :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChunkInfo
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbTraceLedger :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (LedgerDB' blk)
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
cdbCopyLock :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictMVar m ()
cdbNextFollowerKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m FollowerKey
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbTentativeHeader :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (StrictMaybe (Header blk))
cdbTentativeState :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (TentativeState blk)
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
..} = do
    [FollowerHandle m blk]
followerHandles <- STM m [FollowerHandle m blk] -> m [FollowerHandle m blk]
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [FollowerHandle m blk] -> m [FollowerHandle m blk])
-> STM m [FollowerHandle m blk] -> m [FollowerHandle m blk]
forall a b. (a -> b) -> a -> b
$ do
      [FollowerHandle m blk]
followerHandles  <- Map FollowerKey (FollowerHandle m blk) -> [FollowerHandle m blk]
forall k a. Map k a -> [a]
Map.elems (Map FollowerKey (FollowerHandle m blk) -> [FollowerHandle m blk])
-> STM m (Map FollowerKey (FollowerHandle m blk))
-> STM m [FollowerHandle m blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
-> STM m (Map FollowerKey (FollowerHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers
      StrictTVar m (Map FollowerKey (FollowerHandle m blk))
-> Map FollowerKey (FollowerHandle m blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers  Map FollowerKey (FollowerHandle m blk)
forall k a. Map k a
Map.empty
      [FollowerHandle m blk] -> STM m [FollowerHandle m blk]
forall (m :: * -> *) a. Monad m => a -> m a
return [FollowerHandle m blk]
followerHandles
    (FollowerHandle m blk -> m ()) -> [FollowerHandle m blk] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FollowerHandle m blk -> m ()
forall (m :: * -> *) blk. FollowerHandle m blk -> m ()
fhClose [FollowerHandle m blk]
followerHandles