{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
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 Data.Set (Set)
import qualified Data.Set as Set
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
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
import Ouroboros.Consensus.Util.CallStack
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
import Ouroboros.Consensus.Util.STM (blockUntilJust)
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block (ChainUpdate (..))
getFollower ::
forall m blk r. (IOLike m, HasCallStack, HasHeader blk)
=> ChainDbHandle m blk
-> FollowerKey
-> (ChainDbEnv m blk -> m r)
-> m r
getFollower :: forall (m :: * -> *) blk r.
(IOLike m, HasCallStack, HasHeader blk) =>
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 a. HasCallStack => STM m a -> m a
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 a b. STM m a -> (a -> STM m b) -> STM m b
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 e a. Exception e => e -> STM m a
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
$ 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 a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ChainDbEnv m blk
env
else ChainDbError blk -> STM m (ChainDbEnv m blk)
forall e a. Exception e => e -> STM m a
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
$ forall blk. ChainDbError blk
ClosedFollowerError @blk
ChainDbEnv m blk -> m r
f ChainDbEnv m blk
env
getFollower1 ::
forall m blk a r. (IOLike m, HasHeader blk)
=> ChainDbHandle m blk
-> FollowerKey
-> (ChainDbEnv m blk -> a -> m r)
-> a -> m r
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
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)
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 :: 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
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{m (LoE (AnchoredFragment (Header 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 (StrictMaybe (Header blk))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (TentativeHeaderState blk)
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m FollowerKey
StrictTVar m IteratorKey
Fuse m
TopLevelConfig blk
VolatileDB m blk
ResourceRegistry m
ImmutableDB m blk
CheckInFuture m blk
LgrDB m blk
ChainSelQueue m blk
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbImmutableDB :: ImmutableDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbLgrDB :: LgrDB m blk
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbTentativeState :: StrictTVar m (TentativeHeaderState blk)
cdbTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbNextFollowerKey :: StrictTVar m FollowerKey
cdbCopyFuse :: Fuse m
cdbChainSelFuse :: Fuse m
cdbTracer :: Tracer m (TraceEvent blk)
cdbRegistry :: ResourceRegistry m
cdbGcDelay :: DiffTime
cdbGcInterval :: DiffTime
cdbKillBgThreads :: StrictTVar m (m ())
cdbCheckInFuture :: CheckInFuture m blk
cdbChainSelQueue :: ChainSelQueue m blk
cdbFutureBlocks :: StrictTVar m (FutureBlocks m blk)
cdbLoE :: m (LoE (AnchoredFragment (Header blk)))
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbTentativeState :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (TentativeHeaderState blk)
cdbTentativeHeader :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (StrictMaybe (Header blk))
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbNextFollowerKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m FollowerKey
cdbCopyFuse :: forall (m :: * -> *) blk. ChainDbEnv m blk -> Fuse m
cdbChainSelFuse :: forall (m :: * -> *) blk. ChainDbEnv m blk -> Fuse m
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbChainSelQueue :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChainSelQueue m blk
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks m blk)
cdbLoE :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> m (LoE (AnchoredFragment (Header blk)))
..} -> do
FollowerKey
followerKey <- STM m FollowerKey -> m FollowerKey
forall a. HasCallStack => STM m a -> m a
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.
(HasCallStack, MonadSTM m, 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 a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 a. a -> m a
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
{ fhChainType :: ChainType
fhChainType = ChainType
chainType
, fhClose :: m ()
fhClose = do
FollowerState m blk b
followerState <- STM m (FollowerState m blk b) -> m (FollowerState m blk b)
forall a. HasCallStack => STM m a -> m a
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 -> Set (Point blk) -> STM m ()
fhSwitchFork = \Point blk
ipoint Set (Point blk)
oldPoints -> 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
-> Set (Point blk)
-> FollowerState m blk b
-> FollowerState m blk b
forall (m :: * -> *) blk b.
HasHeader blk =>
Point blk
-> Set (Point blk)
-> FollowerState m blk b
-> FollowerState m blk b
switchFork Point blk
ipoint Set (Point blk)
oldPoints
}
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 :: 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 = Follower {m (Maybe (ChainUpdate blk b))
m ()
m (ChainUpdate blk b)
[Point blk] -> m (Maybe (Point blk))
followerInstruction :: m (Maybe (ChainUpdate blk b))
followerInstructionBlocking :: m (ChainUpdate blk b)
followerForward :: [Point blk] -> m (Maybe (Point blk))
followerClose :: m ()
followerInstruction :: m (Maybe (ChainUpdate blk b))
followerInstructionBlocking :: m (ChainUpdate blk b)
followerForward :: [Point blk] -> m (Maybe (Point blk))
followerClose :: m ()
..}
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 a b. (a -> b) -> m a -> m 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 a b. (a -> b) -> STM m a -> STM m b
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
close ::
forall m blk b. IOLike m
=> FollowerKey
-> StrictTVar m (FollowerState m blk b)
-> ChainDbEnv m blk
-> m ()
close :: 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 CDB { StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbFollowers } = do
STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 a. HasCallStack => STM m a -> m a
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
closeFollowerState :: MonadCatch m => FollowerState m blk b -> m ()
closeFollowerState :: forall (m :: * -> *) blk b.
MonadCatch m =>
FollowerState m blk b -> m ()
closeFollowerState = \case
FollowerState m blk b
FollowerInit -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
FollowerInMem FollowerRollState blk
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
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))))
-> ChainDbEnv m blk
-> m (f (ChainUpdate blk b))
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))))
-> 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{m (LoE (AnchoredFragment (Header 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 (StrictMaybe (Header blk))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (TentativeHeaderState blk)
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m FollowerKey
StrictTVar m IteratorKey
Fuse m
TopLevelConfig blk
VolatileDB m blk
ResourceRegistry m
ImmutableDB m blk
CheckInFuture m blk
LgrDB m blk
ChainSelQueue m blk
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbTentativeState :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (TentativeHeaderState blk)
cdbTentativeHeader :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (StrictMaybe (Header blk))
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbNextFollowerKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m FollowerKey
cdbCopyFuse :: forall (m :: * -> *) blk. ChainDbEnv m blk -> Fuse m
cdbChainSelFuse :: forall (m :: * -> *) blk. ChainDbEnv m blk -> Fuse m
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbChainSelQueue :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChainSelQueue m blk
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks m blk)
cdbLoE :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> m (LoE (AnchoredFragment (Header blk)))
cdbImmutableDB :: ImmutableDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbLgrDB :: LgrDB m blk
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbTentativeState :: StrictTVar m (TentativeHeaderState blk)
cdbTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbNextFollowerKey :: StrictTVar m FollowerKey
cdbCopyFuse :: Fuse m
cdbChainSelFuse :: Fuse m
cdbTracer :: Tracer m (TraceEvent blk)
cdbRegistry :: ResourceRegistry m
cdbGcDelay :: DiffTime
cdbGcInterval :: DiffTime
cdbKillBgThreads :: StrictTVar m (m ())
cdbCheckInFuture :: CheckInFuture m blk
cdbChainSelQueue :: ChainSelQueue m blk
cdbFutureBlocks :: StrictTVar m (FutureBlocks m blk)
cdbLoE :: m (LoE (AnchoredFragment (Header blk)))
..} = do
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 a. HasCallStack => STM m a -> m a
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 a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
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 a. a -> STM m a
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 {k} (block :: k). 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 a. a -> STM m a
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 {k1} {k2} (b :: k1) (b' :: k2).
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
-> (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 a b. (a -> b) -> STM m a -> STM m b
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
-> 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. a -> STM m a
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
Right f (ChainUpdate blk (Header blk))
fupdate -> f (ChainUpdate blk (Header blk)) -> m (f (ChainUpdate blk b))
headerUpdateToBlockComponentUpdate f (ChainUpdate blk (Header blk))
fupdate
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Iterator m blk (Point blk, b)
immIt
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 a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent 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 a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 a. a -> m a
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 a. a -> f a
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 {k} (block :: k) 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 a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> 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 a. a -> STM m a
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ChainUpdate blk a -> f (ChainUpdate blk b)
traverse (Header blk -> BlockComponent blk b -> m b
forall b'. Header blk -> BlockComponent blk b' -> m b'
`getBlockComponentFromHeader` BlockComponent blk b
blockComponent))
getBlockComponentFromHeader
:: forall b'. Header blk -> BlockComponent blk b' -> m b'
getBlockComponentFromHeader :: forall b'. Header blk -> BlockComponent blk b' -> m b'
getBlockComponentFromHeader Header blk
hdr = \case
BlockComponent blk b'
GetVerifiedBlock -> BlockComponent blk b' -> m b'
forall c. BlockComponent blk c -> m c
getBlockComponent BlockComponent blk blk
BlockComponent blk b'
forall blk. BlockComponent blk blk
GetVerifiedBlock
BlockComponent blk b'
GetBlock -> BlockComponent blk b' -> m b'
forall c. BlockComponent blk c -> m c
getBlockComponent BlockComponent blk blk
BlockComponent blk b'
forall blk. BlockComponent blk blk
GetBlock
BlockComponent blk b'
GetRawBlock -> BlockComponent blk b' -> m b'
forall c. BlockComponent blk c -> m c
getBlockComponent BlockComponent blk b'
BlockComponent blk ByteString
forall blk. BlockComponent blk ByteString
GetRawBlock
BlockComponent blk b'
GetHeader -> Header blk -> m (Header blk)
forall a. a -> m a
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 a. a -> m a
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 a. a -> m a
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 a. a -> m a
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 a. a -> m a
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 b' -> m b'
forall c. BlockComponent blk c -> m c
getBlockComponent BlockComponent blk b'
BlockComponent blk SizeInBytes
forall blk. BlockComponent blk SizeInBytes
GetBlockSize
BlockComponent blk b'
GetHeaderSize -> b' -> m b'
forall a. a -> m a
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 -> b' -> m b'
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b'
SomeSecond (NestedCtxt Header) blk
nestedCtxt
GetPure b'
a -> b' -> m b'
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b'
a
GetApply BlockComponent blk (a1 -> b')
f BlockComponent blk a1
bc ->
Header blk -> BlockComponent blk (a1 -> b') -> m (a1 -> b')
forall b'. Header blk -> BlockComponent blk b' -> m b'
getBlockComponentFromHeader Header blk
hdr BlockComponent blk (a1 -> b')
f m (a1 -> b') -> m a1 -> m b'
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Header blk -> BlockComponent blk a1 -> m a1
forall b'. Header blk -> BlockComponent blk b' -> m b'
getBlockComponentFromHeader Header blk
hdr BlockComponent blk a1
bc
where
getBlockComponent :: forall c. BlockComponent blk c -> m c
getBlockComponent :: forall c. 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), HasHeader 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 {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
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 a.
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 a b. m a -> (a -> m b) -> m 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 a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 a. a -> m a
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 a. a -> f a
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 {k} (block :: k) a. a -> ChainUpdate block a
AddBlock b
b
Maybe (Point blk, b)
Nothing -> do
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
Point blk
pointAtImmutableDBTip
<- STM m (Point blk) -> m (Point blk)
forall a. HasCallStack => STM m a -> m a
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 {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
pointAtImmutableDBTip
case Point blk -> WithOrigin SlotNo
forall {k} (block :: k). 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
Ordering
GT -> [Char] -> m (f (ChainUpdate blk b))
forall a. HasCallStack => [Char] -> a
error [Char]
"follower streamed beyond tip of the ImmutableDB"
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 a. HasCallStack => STM m a -> m a
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)
f (ChainUpdate blk (Header blk)) -> m (f (ChainUpdate blk b))
headerUpdateToBlockComponentUpdate f (ChainUpdate blk (Header blk))
fupdate
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 a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent blk b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk b
blockComponent) 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
instructionSTM ::
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 :: 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 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 {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
pt) AnchoredFragment (Header blk)
curChain of
Maybe (Header blk)
Nothing -> Maybe (ChainUpdate blk (Header blk))
-> STM m (Maybe (ChainUpdate blk (Header blk)))
forall a. a -> STM m a
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 a. a -> STM m a
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 {k} (block :: k) 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 a. a -> STM m a
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 {k} (block :: k) 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 {k1} {k2} (b :: k1) (b' :: k2).
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 :: 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 CDB{m (LoE (AnchoredFragment (Header 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 (StrictMaybe (Header blk))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (TentativeHeaderState blk)
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m FollowerKey
StrictTVar m IteratorKey
Fuse m
TopLevelConfig blk
VolatileDB m blk
ResourceRegistry m
ImmutableDB m blk
CheckInFuture m blk
LgrDB m blk
ChainSelQueue m blk
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbTentativeState :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (TentativeHeaderState blk)
cdbTentativeHeader :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (StrictMaybe (Header blk))
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbNextFollowerKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m FollowerKey
cdbCopyFuse :: forall (m :: * -> *) blk. ChainDbEnv m blk -> Fuse m
cdbChainSelFuse :: forall (m :: * -> *) blk. ChainDbEnv m blk -> Fuse m
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbChainSelQueue :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChainSelQueue m blk
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks m blk)
cdbLoE :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> m (LoE (AnchoredFragment (Header blk)))
cdbImmutableDB :: ImmutableDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbLgrDB :: LgrDB m blk
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbTentativeState :: StrictTVar m (TentativeHeaderState blk)
cdbTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbNextFollowerKey :: StrictTVar m FollowerKey
cdbCopyFuse :: Fuse m
cdbChainSelFuse :: Fuse m
cdbTracer :: Tracer m (TraceEvent blk)
cdbRegistry :: ResourceRegistry m
cdbGcDelay :: DiffTime
cdbGcInterval :: DiffTime
cdbKillBgThreads :: StrictTVar m (m ())
cdbCheckInFuture :: CheckInFuture m blk
cdbChainSelQueue :: ChainSelQueue m blk
cdbFutureBlocks :: StrictTVar m (FutureBlocks m blk)
cdbLoE :: m (LoE (AnchoredFragment (Header blk)))
..} = \[Point blk]
pts -> do
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 a. HasCallStack => STM m a -> m a
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 a b. STM m (a -> b) -> STM m a -> STM m b
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 a b. STM m (a -> b) -> STM m a -> STM m b
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 a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Point blk] -> STM m [Point blk]
forall a. a -> STM m a
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 :: HasCallStack =>
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 a. a -> m a
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 {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
pt) AnchoredFragment (Header blk)
curChain
-> do
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 a. a -> m a
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
-> 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 {k} (block :: k). Point block
GenesisPoint
-> Maybe (Point blk) -> m (Maybe (Point blk))
forall a. a -> m a
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
-> Maybe (Point blk) -> m (Maybe (Point blk))
forall a. a -> m a
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
-> do
STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 a. a -> m a
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
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 a. a -> m a
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 a b.
BlockComponent blk (a -> b)
-> BlockComponent blk a -> BlockComponent 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 a. a -> m a
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
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
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 a. HasCallStack => STM m a -> m a
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
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
FollowerInMem FollowerRollState blk
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
switchFork ::
forall m blk b. HasHeader blk
=> Point blk
-> Set (Point blk)
-> FollowerState m blk b
-> FollowerState m blk b
switchFork :: forall (m :: * -> *) blk b.
HasHeader blk =>
Point blk
-> Set (Point blk)
-> FollowerState m blk b
-> FollowerState m blk b
switchFork Point blk
ipoint Set (Point blk)
oldPoints =
\case
FollowerInMem (RollBackTo Point blk
pt)
| Point blk
pt Point blk -> Set (Point blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Point blk)
oldPoints -> FollowerRollState blk -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk -> FollowerState m blk b
FollowerInMem (Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState blk
RollBackTo Point blk
ipoint)
FollowerInMem (RollForwardFrom Point blk
pt)
| Point blk
pt Point blk -> Set (Point blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Point blk)
oldPoints -> FollowerRollState blk -> FollowerState m blk b
forall (m :: * -> *) blk b.
FollowerRollState blk -> FollowerState m blk b
FollowerInMem (Point blk -> FollowerRollState blk
forall blk. Point blk -> FollowerRollState blk
RollBackTo Point blk
ipoint)
FollowerState m blk b
followerState -> FollowerState m blk b
followerState
closeAllFollowers ::
IOLike m
=> ChainDbEnv m blk
-> m ()
closeAllFollowers :: forall (m :: * -> *) blk. IOLike m => ChainDbEnv m blk -> m ()
closeAllFollowers CDB{m (LoE (AnchoredFragment (Header 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 (StrictMaybe (Header blk))
StrictTVar m (AnchoredFragment (Header blk))
StrictTVar m (TentativeHeaderState blk)
StrictTVar m (WithFingerprint (InvalidBlocks blk))
StrictTVar m FollowerKey
StrictTVar m IteratorKey
Fuse m
TopLevelConfig blk
VolatileDB m blk
ResourceRegistry m
ImmutableDB m blk
CheckInFuture m blk
LgrDB m blk
ChainSelQueue m blk
cdbFollowers :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbImmutableDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ImmutableDB m blk
cdbVolatileDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> VolatileDB m blk
cdbLgrDB :: forall (m :: * -> *) blk. ChainDbEnv m blk -> LgrDB m blk
cdbChain :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (AnchoredFragment (Header blk))
cdbTentativeState :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (TentativeHeaderState blk)
cdbTentativeHeader :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (StrictMaybe (Header blk))
cdbIterators :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (Map IteratorKey (m ()))
cdbTopLevelConfig :: forall (m :: * -> *) blk. ChainDbEnv m blk -> TopLevelConfig blk
cdbInvalid :: forall (m :: * -> *) blk.
ChainDbEnv m blk
-> StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbNextIteratorKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m IteratorKey
cdbNextFollowerKey :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m FollowerKey
cdbCopyFuse :: forall (m :: * -> *) blk. ChainDbEnv m blk -> Fuse m
cdbChainSelFuse :: forall (m :: * -> *) blk. ChainDbEnv m blk -> Fuse m
cdbTracer :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> Tracer m (TraceEvent blk)
cdbRegistry :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ResourceRegistry m
cdbGcDelay :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbGcInterval :: forall (m :: * -> *) blk. ChainDbEnv m blk -> DiffTime
cdbKillBgThreads :: forall (m :: * -> *) blk. ChainDbEnv m blk -> StrictTVar m (m ())
cdbCheckInFuture :: forall (m :: * -> *) blk. ChainDbEnv m blk -> CheckInFuture m blk
cdbChainSelQueue :: forall (m :: * -> *) blk. ChainDbEnv m blk -> ChainSelQueue m blk
cdbFutureBlocks :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> StrictTVar m (FutureBlocks m blk)
cdbLoE :: forall (m :: * -> *) blk.
ChainDbEnv m blk -> m (LoE (AnchoredFragment (Header blk)))
cdbImmutableDB :: ImmutableDB m blk
cdbVolatileDB :: VolatileDB m blk
cdbLgrDB :: LgrDB m blk
cdbChain :: StrictTVar m (AnchoredFragment (Header blk))
cdbTentativeState :: StrictTVar m (TentativeHeaderState blk)
cdbTentativeHeader :: StrictTVar m (StrictMaybe (Header blk))
cdbIterators :: StrictTVar m (Map IteratorKey (m ()))
cdbFollowers :: StrictTVar m (Map FollowerKey (FollowerHandle m blk))
cdbTopLevelConfig :: TopLevelConfig blk
cdbInvalid :: StrictTVar m (WithFingerprint (InvalidBlocks blk))
cdbNextIteratorKey :: StrictTVar m IteratorKey
cdbNextFollowerKey :: StrictTVar m FollowerKey
cdbCopyFuse :: Fuse m
cdbChainSelFuse :: Fuse m
cdbTracer :: Tracer m (TraceEvent blk)
cdbRegistry :: ResourceRegistry m
cdbGcDelay :: DiffTime
cdbGcInterval :: DiffTime
cdbKillBgThreads :: StrictTVar m (m ())
cdbCheckInFuture :: CheckInFuture m blk
cdbChainSelQueue :: ChainSelQueue m blk
cdbFutureBlocks :: StrictTVar m (FutureBlocks m blk)
cdbLoE :: m (LoE (AnchoredFragment (Header blk)))
..} = do
[FollowerHandle m blk]
followerHandles <- STM m [FollowerHandle m blk] -> m [FollowerHandle m blk]
forall a. HasCallStack => STM m a -> m a
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 a. a -> STM m a
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