{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping (
Context
, ContextWith (..)
, Instruction (..)
, JumpInstruction (..)
, JumpResult (..)
, Jumping (..)
, TraceCsjReason (..)
, TraceEventCsj (..)
, TraceEventDbf (..)
, getDynamo
, makeContext
, mkJumping
, noJumping
, registerClient
, rotateDynamo
, unregisterClient
) where
import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
import Control.Monad (forM, forM_, when)
import Control.Tracer (Tracer, traceWith)
import Data.Foldable (toList, traverse_)
import Data.List (sortOn)
import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as Seq
import qualified Data.Strict.Either as Strict
import Data.Typeable (Typeable)
import Data.Void (absurd)
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block (HasHeader (getHeaderFields), Header,
Point (..), castPoint, pointSlot, succWithOrigin)
import Ouroboros.Consensus.Ledger.SupportsProtocol
(LedgerSupportsProtocol)
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State
(ChainSyncClientHandle (..),
ChainSyncClientHandleCollection (..),
ChainSyncJumpingJumperState (..),
ChainSyncJumpingState (..), ChainSyncState (..),
DisengagedInitState (..), DynamoInitState (..),
JumpInfo (..), JumperInitState (..),
ObjectorInitState (..))
import Ouroboros.Consensus.Node.GsmState (GsmState)
import qualified Ouroboros.Consensus.Node.GsmState as GSM
import Ouroboros.Consensus.Util
import Ouroboros.Consensus.Util.IOLike hiding (handle)
import qualified Ouroboros.Network.AnchoredFragment as AF
data Jumping m blk = Jumping
{
forall (m :: * -> *) blk. Jumping m blk -> m (Instruction blk)
jgNextInstruction :: !(m (Instruction blk)),
forall (m :: * -> *) blk. Jumping m blk -> m ()
jgOnAwaitReply :: !(m ()),
forall (m :: * -> *) blk.
Jumping m blk -> Point (Header blk) -> m ()
jgOnRollForward :: !(Point (Header blk) -> m ()),
forall (m :: * -> *) blk.
Jumping m blk -> WithOrigin SlotNo -> m ()
jgOnRollBackward :: !(WithOrigin SlotNo -> m ()),
forall (m :: * -> *) blk. Jumping m blk -> JumpResult blk -> m ()
jgProcessJumpResult :: !(JumpResult blk -> m ()),
forall (m :: * -> *) blk. Jumping m blk -> JumpInfo blk -> STM m ()
jgUpdateJumpInfo :: !(JumpInfo blk -> STM m ())
}
deriving stock ((forall x. Jumping m blk -> Rep (Jumping m blk) x)
-> (forall x. Rep (Jumping m blk) x -> Jumping m blk)
-> Generic (Jumping m blk)
forall x. Rep (Jumping m blk) x -> Jumping m blk
forall x. Jumping m blk -> Rep (Jumping m blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) blk x. Rep (Jumping m blk) x -> Jumping m blk
forall (m :: * -> *) blk x. Jumping m blk -> Rep (Jumping m blk) x
$cfrom :: forall (m :: * -> *) blk x. Jumping m blk -> Rep (Jumping m blk) x
from :: forall x. Jumping m blk -> Rep (Jumping m blk) x
$cto :: forall (m :: * -> *) blk x. Rep (Jumping m blk) x -> Jumping m blk
to :: forall x. Rep (Jumping m blk) x -> Jumping m blk
Generic)
deriving anyclass instance
( IOLike m,
HasHeader blk,
NoThunks (Header blk)
) =>
NoThunks (Jumping m blk)
noJumping :: (MonadSTM m) => Jumping m blk
noJumping :: forall (m :: * -> *) blk. MonadSTM m => Jumping m blk
noJumping =
Jumping
{ jgNextInstruction :: m (Instruction blk)
jgNextInstruction = Instruction blk -> m (Instruction blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Instruction blk
forall blk. Instruction blk
RunNormally
, jgOnAwaitReply :: m ()
jgOnAwaitReply = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, jgOnRollForward :: Point (Header blk) -> m ()
jgOnRollForward = m () -> Point (Header blk) -> m ()
forall a b. a -> b -> a
const (m () -> Point (Header blk) -> m ())
-> m () -> Point (Header blk) -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, jgOnRollBackward :: WithOrigin SlotNo -> m ()
jgOnRollBackward = m () -> WithOrigin SlotNo -> m ()
forall a b. a -> b -> a
const (m () -> WithOrigin SlotNo -> m ())
-> m () -> WithOrigin SlotNo -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, jgProcessJumpResult :: JumpResult blk -> m ()
jgProcessJumpResult = m () -> JumpResult blk -> m ()
forall a b. a -> b -> a
const (m () -> JumpResult blk -> m ()) -> m () -> JumpResult blk -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, jgUpdateJumpInfo :: JumpInfo blk -> STM m ()
jgUpdateJumpInfo = STM m () -> JumpInfo blk -> STM m ()
forall a b. a -> b -> a
const (STM m () -> JumpInfo blk -> STM m ())
-> STM m () -> JumpInfo blk -> STM m ()
forall a b. (a -> b) -> a -> b
$ () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
}
mkJumping ::
( MonadSTM m,
Eq peer,
LedgerSupportsProtocol blk
) =>
PeerContext m peer blk ->
Jumping m blk
mkJumping :: forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> Jumping m blk
mkJumping PeerContext m peer blk
peerContext = Jumping
{ jgNextInstruction :: m (Instruction blk)
jgNextInstruction =
STM m (Either () (Instruction blk))
-> m (Either () (Instruction blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ()
-> PeerContext m peer blk -> STM m (Either () (Instruction blk))
forall (m :: * -> *) retry peer blk.
MonadSTM m =>
STM m retry
-> PeerContext m peer blk -> STM m (Either retry (Instruction blk))
nextInstruction (() -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) PeerContext m peer blk
peerContext) m (Either () (Instruction blk))
-> (Either () (Instruction blk) -> m (Instruction blk))
-> m (Instruction blk)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Strict.Right Instruction blk
instr -> Instruction blk -> m (Instruction blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Instruction blk
instr
Strict.Left () -> do
Tracer m (TraceEventCsj peer blk) -> TraceEventCsj peer blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (PeerContext m peer blk -> Tracer m (TraceEventCsj peer blk)
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> Tracer m (TraceEventCsj peer blk)
tracer PeerContext m peer blk
peerContext) TraceEventCsj peer blk
forall peer blk. TraceEventCsj peer blk
BlockedOnJump
m (Instruction blk) -> m (Instruction blk)
forall a. a -> a
id
(m (Instruction blk) -> m (Instruction blk))
-> m (Instruction blk) -> m (Instruction blk)
forall a b. (a -> b) -> a -> b
$ (Either Void (Instruction blk) -> Instruction blk)
-> m (Either Void (Instruction blk)) -> m (Instruction blk)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Void -> Instruction blk)
-> (Instruction blk -> Instruction blk)
-> Either Void (Instruction blk)
-> Instruction blk
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
Strict.either Void -> Instruction blk
forall a. Void -> a
absurd Instruction blk -> Instruction blk
forall a. a -> a
id)
(m (Either Void (Instruction blk)) -> m (Instruction blk))
-> m (Either Void (Instruction blk)) -> m (Instruction blk)
forall a b. (a -> b) -> a -> b
$ STM m (Either Void (Instruction blk))
-> m (Either Void (Instruction blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically
(STM m (Either Void (Instruction blk))
-> m (Either Void (Instruction blk)))
-> STM m (Either Void (Instruction blk))
-> m (Either Void (Instruction blk))
forall a b. (a -> b) -> a -> b
$ STM m Void
-> PeerContext m peer blk -> STM m (Either Void (Instruction blk))
forall (m :: * -> *) retry peer blk.
MonadSTM m =>
STM m retry
-> PeerContext m peer blk -> STM m (Either retry (Instruction blk))
nextInstruction STM m Void
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry PeerContext m peer blk
peerContext
, jgOnAwaitReply :: m ()
jgOnAwaitReply = STM m (Maybe (TraceEventCsj peer blk)) -> m ()
forall {t :: * -> *}.
Foldable t =>
STM m (t (TraceEventCsj peer blk)) -> m ()
f (STM m (Maybe (TraceEventCsj peer blk)) -> m ())
-> STM m (Maybe (TraceEventCsj peer blk)) -> m ()
forall a b. (a -> b) -> a -> b
$ PeerContext m peer blk -> STM m (Maybe (TraceEventCsj peer blk))
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> STM m (Maybe (TraceEventCsj peer blk))
onAwaitReply PeerContext m peer blk
peerContext
, jgOnRollForward :: Point (Header blk) -> m ()
jgOnRollForward = STM m (Maybe (TraceEventCsj peer blk)) -> m ()
forall {t :: * -> *}.
Foldable t =>
STM m (t (TraceEventCsj peer blk)) -> m ()
f (STM m (Maybe (TraceEventCsj peer blk)) -> m ())
-> (Point (Header blk) -> STM m (Maybe (TraceEventCsj peer blk)))
-> Point (Header blk)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerContext m peer blk
-> Point (Header blk) -> STM m (Maybe (TraceEventCsj peer blk))
forall (m :: * -> *) peer blk.
(MonadSTM m, LedgerSupportsProtocol blk) =>
PeerContext m peer blk
-> Point (Header blk) -> STM m (Maybe (TraceEventCsj peer blk))
onRollForward PeerContext m peer blk
peerContext
, jgOnRollBackward :: WithOrigin SlotNo -> m ()
jgOnRollBackward = STM m (Maybe (TraceEventCsj peer blk)) -> m ()
forall {t :: * -> *}.
Foldable t =>
STM m (t (TraceEventCsj peer blk)) -> m ()
f (STM m (Maybe (TraceEventCsj peer blk)) -> m ())
-> (WithOrigin SlotNo -> STM m (Maybe (TraceEventCsj peer blk)))
-> WithOrigin SlotNo
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerContext m peer blk
-> WithOrigin SlotNo -> STM m (Maybe (TraceEventCsj peer blk))
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk
-> WithOrigin SlotNo -> STM m (Maybe (TraceEventCsj peer blk))
onRollBackward PeerContext m peer blk
peerContext
, jgProcessJumpResult :: JumpResult blk -> m ()
jgProcessJumpResult = STM m (Maybe (TraceEventCsj peer blk)) -> m ()
forall {t :: * -> *}.
Foldable t =>
STM m (t (TraceEventCsj peer blk)) -> m ()
f (STM m (Maybe (TraceEventCsj peer blk)) -> m ())
-> (JumpResult blk -> STM m (Maybe (TraceEventCsj peer blk)))
-> JumpResult blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerContext m peer blk
-> JumpResult blk -> STM m (Maybe (TraceEventCsj peer blk))
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk
-> JumpResult blk -> STM m (Maybe (TraceEventCsj peer blk))
processJumpResult PeerContext m peer blk
peerContext
, jgUpdateJumpInfo :: JumpInfo blk -> STM m ()
jgUpdateJumpInfo = PeerContext m peer blk -> JumpInfo blk -> STM m ()
forall (m :: * -> *) peer blk.
MonadSTM m =>
PeerContext m peer blk -> JumpInfo blk -> STM m ()
updateJumpInfo PeerContext m peer blk
peerContext
}
where
f :: STM m (t (TraceEventCsj peer blk)) -> m ()
f STM m (t (TraceEventCsj peer blk))
m = STM m (t (TraceEventCsj peer blk))
-> m (t (TraceEventCsj peer blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (t (TraceEventCsj peer blk))
m m (t (TraceEventCsj peer blk))
-> (t (TraceEventCsj peer blk) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TraceEventCsj peer blk -> m ())
-> t (TraceEventCsj peer blk) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Tracer m (TraceEventCsj peer blk) -> TraceEventCsj peer blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (PeerContext m peer blk -> Tracer m (TraceEventCsj peer blk)
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> Tracer m (TraceEventCsj peer blk)
tracer PeerContext m peer blk
peerContext))
data ContextWith peerField handleField m peer blk = Context
{ forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> peerField
peer :: !peerField,
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle :: !handleField,
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> ChainSyncClientHandleCollection peer m blk
handlesCol :: !(ChainSyncClientHandleCollection peer m blk),
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> SlotNo
jumpSize :: !SlotNo,
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> Tracer m (TraceEventCsj peer blk)
tracer :: Tracer m (TraceEventCsj peer blk)
}
type Context = ContextWith () ()
type PeerContext m peer blk = ContextWith peer (ChainSyncClientHandle m blk) m peer blk
makeContext ::
MonadSTM m =>
ChainSyncClientHandleCollection peer m blk ->
SlotNo ->
Tracer m (TraceEventCsj peer blk) ->
STM m (Context m peer blk)
makeContext :: forall (m :: * -> *) peer blk.
MonadSTM m =>
ChainSyncClientHandleCollection peer m blk
-> SlotNo
-> Tracer m (TraceEventCsj peer blk)
-> STM m (Context m peer blk)
makeContext ChainSyncClientHandleCollection peer m blk
h SlotNo
jumpSize Tracer m (TraceEventCsj peer blk)
tracer = do
Context m peer blk -> STM m (Context m peer blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context m peer blk -> STM m (Context m peer blk))
-> Context m peer blk -> STM m (Context m peer blk)
forall a b. (a -> b) -> a -> b
$ ()
-> ()
-> ChainSyncClientHandleCollection peer m blk
-> SlotNo
-> Tracer m (TraceEventCsj peer blk)
-> Context m peer blk
forall peerField handleField (m :: * -> *) peer blk.
peerField
-> handleField
-> ChainSyncClientHandleCollection peer m blk
-> SlotNo
-> Tracer m (TraceEventCsj peer blk)
-> ContextWith peerField handleField m peer blk
Context () () ChainSyncClientHandleCollection peer m blk
h SlotNo
jumpSize Tracer m (TraceEventCsj peer blk)
tracer
stripContext :: PeerContext m peer blk -> Context m peer blk
stripContext :: forall (m :: * -> *) peer blk.
PeerContext m peer blk -> Context m peer blk
stripContext PeerContext m peer blk
context = PeerContext m peer blk
context {peer = (), handle = ()}
data Instruction blk
= RunNormally
| Restart
|
JumpInstruction !(JumpInstruction blk)
deriving ((forall x. Instruction blk -> Rep (Instruction blk) x)
-> (forall x. Rep (Instruction blk) x -> Instruction blk)
-> Generic (Instruction blk)
forall x. Rep (Instruction blk) x -> Instruction blk
forall x. Instruction blk -> Rep (Instruction blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (Instruction blk) x -> Instruction blk
forall blk x. Instruction blk -> Rep (Instruction blk) x
$cfrom :: forall blk x. Instruction blk -> Rep (Instruction blk) x
from :: forall x. Instruction blk -> Rep (Instruction blk) x
$cto :: forall blk x. Rep (Instruction blk) x -> Instruction blk
to :: forall x. Rep (Instruction blk) x -> Instruction blk
Generic)
deriving instance (Typeable blk, HasHeader (Header blk), Eq (Header blk)) => Eq (Instruction blk)
deriving instance (Typeable blk, HasHeader (Header blk), Show (Header blk)) => Show (Instruction blk)
deriving anyclass instance
( HasHeader blk,
LedgerSupportsProtocol blk,
NoThunks (Header blk)
) => NoThunks (Instruction blk)
data JumpInstruction blk
= JumpTo !(JumpInfo blk)
|
JumpToGoodPoint !(JumpInfo blk)
deriving ((forall x. JumpInstruction blk -> Rep (JumpInstruction blk) x)
-> (forall x. Rep (JumpInstruction blk) x -> JumpInstruction blk)
-> Generic (JumpInstruction blk)
forall x. Rep (JumpInstruction blk) x -> JumpInstruction blk
forall x. JumpInstruction blk -> Rep (JumpInstruction blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (JumpInstruction blk) x -> JumpInstruction blk
forall blk x. JumpInstruction blk -> Rep (JumpInstruction blk) x
$cfrom :: forall blk x. JumpInstruction blk -> Rep (JumpInstruction blk) x
from :: forall x. JumpInstruction blk -> Rep (JumpInstruction blk) x
$cto :: forall blk x. Rep (JumpInstruction blk) x -> JumpInstruction blk
to :: forall x. Rep (JumpInstruction blk) x -> JumpInstruction blk
Generic)
deriving instance (Typeable blk, HasHeader (Header blk), Eq (Header blk)) => Eq (JumpInstruction blk)
instance (Typeable blk, HasHeader (Header blk), Show (Header blk)) => Show (JumpInstruction blk) where
showsPrec :: Int -> JumpInstruction blk -> ShowS
showsPrec Int
p = \case
JumpTo JumpInfo blk
jumpInfo ->
Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"JumpTo " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point (HeaderWithTime blk) -> ShowS
forall a. Show a => a -> ShowS
shows (AnchoredFragment (HeaderWithTime blk) -> Point (HeaderWithTime blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (HeaderWithTime blk)
-> Point (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
-> Point (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
jumpInfo)
JumpToGoodPoint JumpInfo blk
jumpInfo ->
Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"JumpToGoodPoint " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point (HeaderWithTime blk) -> ShowS
forall a. Show a => a -> ShowS
shows (AnchoredFragment (HeaderWithTime blk) -> Point (HeaderWithTime blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (HeaderWithTime blk)
-> Point (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
-> Point (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
jumpInfo)
deriving anyclass instance
( HasHeader blk,
LedgerSupportsProtocol blk,
NoThunks (Header blk)
) => NoThunks (JumpInstruction blk)
data JumpResult blk
= AcceptedJump !(JumpInstruction blk)
| RejectedJump !(JumpInstruction blk)
deriving ((forall x. JumpResult blk -> Rep (JumpResult blk) x)
-> (forall x. Rep (JumpResult blk) x -> JumpResult blk)
-> Generic (JumpResult blk)
forall x. Rep (JumpResult blk) x -> JumpResult blk
forall x. JumpResult blk -> Rep (JumpResult blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (JumpResult blk) x -> JumpResult blk
forall blk x. JumpResult blk -> Rep (JumpResult blk) x
$cfrom :: forall blk x. JumpResult blk -> Rep (JumpResult blk) x
from :: forall x. JumpResult blk -> Rep (JumpResult blk) x
$cto :: forall blk x. Rep (JumpResult blk) x -> JumpResult blk
to :: forall x. Rep (JumpResult blk) x -> JumpResult blk
Generic)
deriving instance (Typeable blk, HasHeader (Header blk), Eq (Header blk)) => Eq (JumpResult blk)
deriving instance (Typeable blk, HasHeader (Header blk), Show (Header blk)) => Show (JumpResult blk)
deriving anyclass instance
( HasHeader blk,
LedgerSupportsProtocol blk,
NoThunks (Header blk)
) => NoThunks (JumpResult blk)
nextInstruction ::
( MonadSTM m ) =>
STM m retry ->
PeerContext m peer blk ->
STM m (Strict.Either retry (Instruction blk))
nextInstruction :: forall (m :: * -> *) retry peer blk.
MonadSTM m =>
STM m retry
-> PeerContext m peer blk -> STM m (Either retry (Instruction blk))
nextInstruction STM m retry
retry_ PeerContext m peer blk
context =
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk
-> STM m (Either retry (Instruction blk)))
-> STM m (Either retry (Instruction 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
Disengaged DisengagedInitState
DisengagedDone -> Instruction blk -> STM m (Either retry (Instruction blk))
forall {a} {a}. a -> STM m (Either a a)
pur Instruction blk
forall blk. Instruction blk
RunNormally
Disengaged DisengagedInitState
Disengaging -> do
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (DisengagedInitState -> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
DisengagedInitState -> ChainSyncJumpingState m blk
Disengaged DisengagedInitState
DisengagedDone)
Instruction blk -> STM m (Either retry (Instruction blk))
forall {a} {a}. a -> STM m (Either a a)
pur Instruction blk
forall blk. Instruction blk
Restart
Dynamo (DynamoStarting JumpInfo blk
goodJumpInfo) WithOrigin SlotNo
lastJumpSlot -> do
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (ChainSyncJumpingState m blk -> STM m ())
-> ChainSyncJumpingState m blk -> STM m ()
forall a b. (a -> b) -> a -> b
$
DynamoInitState blk
-> WithOrigin SlotNo -> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
DynamoInitState blk
-> WithOrigin SlotNo -> ChainSyncJumpingState m blk
Dynamo DynamoInitState blk
forall blk. DynamoInitState blk
DynamoStarted WithOrigin SlotNo
lastJumpSlot
Instruction blk -> STM m (Either retry (Instruction blk))
forall {a} {a}. a -> STM m (Either a a)
pur (Instruction blk -> STM m (Either retry (Instruction blk)))
-> Instruction blk -> STM m (Either retry (Instruction blk))
forall a b. (a -> b) -> a -> b
$ JumpInstruction blk -> Instruction blk
forall blk. JumpInstruction blk -> Instruction blk
JumpInstruction (JumpInstruction blk -> Instruction blk)
-> JumpInstruction blk -> Instruction blk
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> JumpInstruction blk
forall blk. JumpInfo blk -> JumpInstruction blk
JumpToGoodPoint JumpInfo blk
goodJumpInfo
Dynamo DynamoInitState blk
DynamoStarted WithOrigin SlotNo
_ ->
Instruction blk -> STM m (Either retry (Instruction blk))
forall {a} {a}. a -> STM m (Either a a)
pur (Instruction blk -> STM m (Either retry (Instruction blk)))
-> Instruction blk -> STM m (Either retry (Instruction blk))
forall a b. (a -> b) -> a -> b
$ Instruction blk
forall blk. Instruction blk
RunNormally
Objector ObjectorInitState
Starting JumpInfo blk
goodJump Point (Header blk)
badPoint -> do
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (ChainSyncJumpingState m blk -> STM m ())
-> ChainSyncJumpingState m blk -> STM m ()
forall a b. (a -> b) -> a -> b
$
ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingState m blk
Objector ObjectorInitState
Started JumpInfo blk
goodJump Point (Header blk)
badPoint
Instruction blk -> STM m (Either retry (Instruction blk))
forall {a} {a}. a -> STM m (Either a a)
pur (Instruction blk -> STM m (Either retry (Instruction blk)))
-> Instruction blk -> STM m (Either retry (Instruction blk))
forall a b. (a -> b) -> a -> b
$ JumpInstruction blk -> Instruction blk
forall blk. JumpInstruction blk -> Instruction blk
JumpInstruction (JumpInstruction blk -> Instruction blk)
-> JumpInstruction blk -> Instruction blk
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> JumpInstruction blk
forall blk. JumpInfo blk -> JumpInstruction blk
JumpToGoodPoint JumpInfo blk
goodJump
Objector ObjectorInitState
Started JumpInfo blk
_ Point (Header blk)
_ -> Instruction blk -> STM m (Either retry (Instruction blk))
forall {a} {a}. a -> STM m (Either a a)
pur Instruction blk
forall blk. Instruction blk
RunNormally
Jumper StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar ChainSyncJumpingJumperState blk
jumperState -> do
StrictTVar m (Maybe (JumpInfo blk)) -> STM m (Maybe (JumpInfo blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar STM m (Maybe (JumpInfo blk))
-> (Maybe (JumpInfo blk) -> STM m (Either retry (Instruction blk)))
-> STM m (Either retry (Instruction 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
Maybe (JumpInfo blk)
Nothing -> retry -> Either retry (Instruction blk)
forall a b. a -> Either a b
Strict.Left (retry -> Either retry (Instruction blk))
-> STM m retry -> STM m (Either retry (Instruction blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m retry
retry_
Just JumpInfo blk
jumpInfo -> do
StrictTVar m (Maybe (JumpInfo blk))
-> Maybe (JumpInfo blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar Maybe (JumpInfo blk)
forall a. Maybe a
Nothing
case ChainSyncJumpingJumperState blk
jumperState of
Happy JumperInitState
FreshJumper Maybe (JumpInfo blk)
mGoodJumpInfo ->
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (ChainSyncJumpingState m blk -> STM m ())
-> ChainSyncJumpingState m blk -> STM m ()
forall a b. (a -> b) -> a -> b
$
StrictTVar m (Maybe (JumpInfo blk))
-> ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
StrictTVar m (Maybe (JumpInfo blk))
-> ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk
Jumper StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar (ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk)
-> ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk
forall a b. (a -> b) -> a -> b
$ JumperInitState
-> Maybe (JumpInfo blk) -> ChainSyncJumpingJumperState blk
forall blk.
JumperInitState
-> Maybe (JumpInfo blk) -> ChainSyncJumpingJumperState blk
Happy JumperInitState
StartedJumper Maybe (JumpInfo blk)
mGoodJumpInfo
ChainSyncJumpingJumperState blk
_ -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Instruction blk -> STM m (Either retry (Instruction blk))
forall {a} {a}. a -> STM m (Either a a)
pur (Instruction blk -> STM m (Either retry (Instruction blk)))
-> Instruction blk -> STM m (Either retry (Instruction blk))
forall a b. (a -> b) -> a -> b
$ JumpInstruction blk -> Instruction blk
forall blk. JumpInstruction blk -> Instruction blk
JumpInstruction (JumpInstruction blk -> Instruction blk)
-> JumpInstruction blk -> Instruction blk
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> JumpInstruction blk
forall blk. JumpInfo blk -> JumpInstruction blk
JumpTo JumpInfo blk
jumpInfo
where
pur :: a -> STM m (Either a a)
pur = Either a a -> STM m (Either a a)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a a -> STM m (Either a a))
-> (a -> Either a a) -> a -> STM m (Either a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a a
forall a b. b -> Either a b
Strict.Right
onRollForward :: forall m peer blk.
( MonadSTM m,
LedgerSupportsProtocol blk
) =>
PeerContext m peer blk ->
Point (Header blk) ->
STM m (Maybe (TraceEventCsj peer blk))
onRollForward :: forall (m :: * -> *) peer blk.
(MonadSTM m, LedgerSupportsProtocol blk) =>
PeerContext m peer blk
-> Point (Header blk) -> STM m (Maybe (TraceEventCsj peer blk))
onRollForward PeerContext m peer blk
context Point (Header blk)
point =
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk
-> STM m (Maybe (TraceEventCsj peer blk)))
-> STM m (Maybe (TraceEventCsj peer 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
Objector ObjectorInitState
_ JumpInfo blk
_ Point (Header blk)
badPoint
| Point (Header blk)
badPoint Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
== Point (Header blk) -> Point (Header blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point (Header blk)
point -> do
ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) blk.
MonadSTM m =>
ChainSyncClientHandle m blk -> STM m ()
disengage (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)
(TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk)
-> Maybe (TraceEventCsj peer blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a -> b) -> a -> b
$ TraceCsjReason
BecauseCsjDisengage)) ((TraceCsjReason -> TraceEventCsj peer blk)
-> Maybe (TraceEventCsj peer blk))
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
electNewObjector (PeerContext m peer blk -> Context m peer blk
forall (m :: * -> *) peer blk.
PeerContext m peer blk -> Context m peer blk
stripContext PeerContext m peer blk
context)
| Bool
otherwise -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Disengaged{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Jumper{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Dynamo DynamoInitState blk
_ WithOrigin SlotNo
lastJumpSlot
| let jumpBoundaryPlus1 :: SlotNo
jumpBoundaryPlus1 = PeerContext m peer blk -> SlotNo
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> SlotNo
jumpSize PeerContext m peer blk
context SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin WithOrigin SlotNo
lastJumpSlot
, WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin (Point (Header blk) -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point (Header blk)
point) SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
jumpBoundaryPlus1 -> do
mJumpInfo <- StrictTVar m (Maybe (JumpInfo blk)) -> STM m (Maybe (JumpInfo blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context))
setJumps mJumpInfo
| Bool
otherwise -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
where
setJumps :: Maybe (JumpInfo blk) -> STM m (Maybe (TraceEventCsj peer blk))
setJumps Maybe (JumpInfo blk)
Nothing = String -> STM m (Maybe (TraceEventCsj peer blk))
forall a. HasCallStack => String -> a
error String
"onRollForward: Dynamo without jump info"
setJumps (Just JumpInfo blk
jumpInfo) = do
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (ChainSyncJumpingState m blk -> STM m ())
-> ChainSyncJumpingState m blk -> STM m ()
forall a b. (a -> b) -> a -> b
$
DynamoInitState blk
-> WithOrigin SlotNo -> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
DynamoInitState blk
-> WithOrigin SlotNo -> ChainSyncJumpingState m blk
Dynamo DynamoInitState blk
forall blk. DynamoInitState blk
DynamoStarted (WithOrigin SlotNo -> ChainSyncJumpingState m blk)
-> WithOrigin SlotNo -> ChainSyncJumpingState m blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (HeaderWithTime blk) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot (AnchoredFragment (HeaderWithTime blk) -> WithOrigin SlotNo)
-> AnchoredFragment (HeaderWithTime blk) -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
jumpInfo
handles <- ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
cschcSeq (PeerContext m peer blk
-> ChainSyncClientHandleCollection peer m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> ChainSyncClientHandleCollection peer m blk
handlesCol PeerContext m peer blk
context)
forM_ handles $ \(peer
_, ChainSyncClientHandle m blk
h) ->
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
h) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk -> STM m ()) -> STM m ()
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
Jumper StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar Happy{} -> StrictTVar m (Maybe (JumpInfo blk))
-> Maybe (JumpInfo blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar (JumpInfo blk -> Maybe (JumpInfo blk)
forall a. a -> Maybe a
Just JumpInfo blk
jumpInfo)
ChainSyncJumpingState m blk
_ -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
pure
$ Just
$ SentJumpInstruction
$ castPoint
$ AF.headPoint
$ jTheirFragment jumpInfo
onRollBackward :: forall m peer blk.
( MonadSTM m,
Eq peer,
LedgerSupportsProtocol blk
) =>
PeerContext m peer blk ->
WithOrigin SlotNo ->
STM m (Maybe (TraceEventCsj peer blk))
onRollBackward :: forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk
-> WithOrigin SlotNo -> STM m (Maybe (TraceEventCsj peer blk))
onRollBackward PeerContext m peer blk
context WithOrigin SlotNo
slot =
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk
-> STM m (Maybe (TraceEventCsj peer blk)))
-> STM m (Maybe (TraceEventCsj peer 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
Objector ObjectorInitState
_ JumpInfo blk
_ Point (Header blk)
badPoint
| WithOrigin SlotNo
slot WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< Point (Header blk) -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point (Header blk)
badPoint -> do
ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) blk.
MonadSTM m =>
ChainSyncClientHandle m blk -> STM m ()
disengage (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)
(TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk)
-> Maybe (TraceEventCsj peer blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a -> b) -> a -> b
$ TraceCsjReason
BecauseCsjDisengage)) ((TraceCsjReason -> TraceEventCsj peer blk)
-> Maybe (TraceEventCsj peer blk))
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
electNewObjector (PeerContext m peer blk -> Context m peer blk
forall (m :: * -> *) peer blk.
PeerContext m peer blk -> Context m peer blk
stripContext PeerContext m peer blk
context)
| Bool
otherwise -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Disengaged{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Jumper{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Dynamo DynamoInitState blk
_ WithOrigin SlotNo
lastJumpSlot
| WithOrigin SlotNo
slot WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< WithOrigin SlotNo
lastJumpSlot -> do
ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) blk.
MonadSTM m =>
ChainSyncClientHandle m blk -> STM m ()
disengage (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)
(TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> Maybe (TraceEventCsj peer blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a -> b) -> a -> b
$ TraceCsjReason
BecauseCsjDisengage) ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceEventCsj peer blk)
-> ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceCsjReason -> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceEventCsj peer blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a, b) -> a
fst) ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> Maybe (TraceEventCsj peer blk))
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context m peer blk
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
Context m peer blk
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
backfillDynamo (PeerContext m peer blk -> Context m peer blk
forall (m :: * -> *) peer blk.
PeerContext m peer blk -> Context m peer blk
stripContext PeerContext m peer blk
context)
| Bool
otherwise -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
onAwaitReply ::
( MonadSTM m,
Eq peer,
LedgerSupportsProtocol blk
) =>
PeerContext m peer blk ->
STM m (Maybe (TraceEventCsj peer blk))
onAwaitReply :: forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> STM m (Maybe (TraceEventCsj peer blk))
onAwaitReply PeerContext m peer blk
context =
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk
-> STM m (Maybe (TraceEventCsj peer blk)))
-> STM m (Maybe (TraceEventCsj peer 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
Dynamo{} -> do
ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) blk.
MonadSTM m =>
ChainSyncClientHandle m blk -> STM m ()
disengage (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)
(TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> Maybe (TraceEventCsj peer blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a -> b) -> a -> b
$ TraceCsjReason
BecauseCsjDisengage) ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceEventCsj peer blk)
-> ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceCsjReason -> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceEventCsj peer blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a, b) -> a
fst) ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> Maybe (TraceEventCsj peer blk))
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context m peer blk
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
Context m peer blk
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
backfillDynamo (PeerContext m peer blk -> Context m peer blk
forall (m :: * -> *) peer blk.
PeerContext m peer blk -> Context m peer blk
stripContext PeerContext m peer blk
context)
Objector{} -> do
ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) blk.
MonadSTM m =>
ChainSyncClientHandle m blk -> STM m ()
disengage (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)
(TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk)
-> Maybe (TraceEventCsj peer blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a -> b) -> a -> b
$ TraceCsjReason
BecauseCsjDisengage)) ((TraceCsjReason -> TraceEventCsj peer blk)
-> Maybe (TraceEventCsj peer blk))
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
electNewObjector (PeerContext m peer blk -> Context m peer blk
forall (m :: * -> *) peer blk.
PeerContext m peer blk -> Context m peer blk
stripContext PeerContext m peer blk
context)
Jumper{} ->
() -> Maybe (TraceEventCsj peer blk)
forall a. () -> Maybe a
unitNothing (() -> Maybe (TraceEventCsj peer blk))
-> STM m () -> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) blk.
MonadSTM m =>
ChainSyncClientHandle m blk -> STM m ()
disengage (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)
Disengaged{} ->
Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
processJumpResult :: forall m peer blk.
( MonadSTM m,
Eq peer,
LedgerSupportsProtocol blk
) =>
PeerContext m peer blk ->
JumpResult blk ->
STM m (Maybe (TraceEventCsj peer blk))
processJumpResult :: forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk
-> JumpResult blk -> STM m (Maybe (TraceEventCsj peer blk))
processJumpResult PeerContext m peer blk
context JumpResult blk
jumpResult =
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk
-> STM m (Maybe (TraceEventCsj peer blk)))
-> STM m (Maybe (TraceEventCsj peer 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
Dynamo{} ->
case JumpResult blk
jumpResult of
AcceptedJump (JumpToGoodPoint JumpInfo blk
jumpInfo) ->
() -> Maybe (TraceEventCsj peer blk)
forall a. () -> Maybe a
unitNothing (() -> Maybe (TraceEventCsj peer blk))
-> STM m () -> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClientHandle m blk -> JumpInfo blk -> STM m ()
updateChainSyncState (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context) JumpInfo blk
jumpInfo
RejectedJump JumpToGoodPoint{} -> do
ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) blk.
MonadSTM m =>
ChainSyncClientHandle m blk -> STM m ()
startDisengaging (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)
(TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> Maybe (TraceEventCsj peer blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a -> b) -> a -> b
$ TraceCsjReason
BecauseCsjDisengage) ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceEventCsj peer blk)
-> ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceCsjReason -> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceEventCsj peer blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a, b) -> a
fst) ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> Maybe (TraceEventCsj peer blk))
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context m peer blk
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
Context m peer blk
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
backfillDynamo (PeerContext m peer blk -> Context m peer blk
forall (m :: * -> *) peer blk.
PeerContext m peer blk -> Context m peer blk
stripContext PeerContext m peer blk
context)
AcceptedJump JumpTo{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
RejectedJump JumpTo{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Disengaged{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Objector{} ->
case JumpResult blk
jumpResult of
AcceptedJump (JumpToGoodPoint JumpInfo blk
jumpInfo) ->
() -> Maybe (TraceEventCsj peer blk)
forall a. () -> Maybe a
unitNothing (() -> Maybe (TraceEventCsj peer blk))
-> STM m () -> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClientHandle m blk -> JumpInfo blk -> STM m ()
updateChainSyncState (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context) JumpInfo blk
jumpInfo
RejectedJump JumpToGoodPoint{} -> do
ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) blk.
MonadSTM m =>
ChainSyncClientHandle m blk -> STM m ()
startDisengaging (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)
(TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk)
-> Maybe (TraceEventCsj peer blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a -> b) -> a -> b
$ TraceCsjReason
BecauseCsjDisengage)) ((TraceCsjReason -> TraceEventCsj peer blk)
-> Maybe (TraceEventCsj peer blk))
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
electNewObjector (PeerContext m peer blk -> Context m peer blk
forall (m :: * -> *) peer blk.
PeerContext m peer blk -> Context m peer blk
stripContext PeerContext m peer blk
context)
AcceptedJump JumpTo{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
RejectedJump JumpTo{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Jumper StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar ChainSyncJumpingJumperState blk
jumperState ->
case JumpResult blk
jumpResult of
AcceptedJump (JumpTo JumpInfo blk
goodJumpInfo) -> do
ChainSyncClientHandle m blk -> JumpInfo blk -> STM m ()
updateChainSyncState (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context) JumpInfo blk
goodJumpInfo
StrictTVar m (Maybe (JumpInfo blk))
-> Maybe (JumpInfo blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (Maybe (JumpInfo blk) -> STM m ())
-> Maybe (JumpInfo blk) -> STM m ()
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> Maybe (JumpInfo blk)
forall a. a -> Maybe a
Just JumpInfo blk
goodJumpInfo
case ChainSyncJumpingJumperState blk
jumperState of
LookingForIntersection JumpInfo blk
_goodJumpInfo JumpInfo blk
badJumpInfo ->
StrictTVar m (Maybe (JumpInfo blk))
-> JumpInfo blk
-> JumpInfo blk
-> STM m (Maybe (TraceEventCsj peer blk))
lookForIntersection StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar JumpInfo blk
goodJumpInfo JumpInfo blk
badJumpInfo
Happy JumperInitState
StartedJumper Maybe (JumpInfo blk)
_mGoodJumpInfo -> do
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (ChainSyncJumpingState m blk -> STM m ())
-> ChainSyncJumpingState m blk -> STM m ()
forall a b. (a -> b) -> a -> b
$
StrictTVar m (Maybe (JumpInfo blk))
-> ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
StrictTVar m (Maybe (JumpInfo blk))
-> ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk
Jumper StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar (ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk)
-> ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk
forall a b. (a -> b) -> a -> b
$ JumperInitState
-> Maybe (JumpInfo blk) -> ChainSyncJumpingJumperState blk
forall blk.
JumperInitState
-> Maybe (JumpInfo blk) -> ChainSyncJumpingJumperState blk
Happy JumperInitState
StartedJumper (Maybe (JumpInfo blk) -> ChainSyncJumpingJumperState blk)
-> Maybe (JumpInfo blk) -> ChainSyncJumpingJumperState blk
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> Maybe (JumpInfo blk)
forall a. a -> Maybe a
Just JumpInfo blk
goodJumpInfo
Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Happy JumperInitState
FreshJumper Maybe (JumpInfo blk)
_mGoodJumpInfo ->
Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
FoundIntersection{} ->
String -> STM m (Maybe (TraceEventCsj peer blk))
forall a. HasCallStack => String -> a
error String
"processJumpResult: Jumpers in state FoundIntersection shouldn't be further jumping."
RejectedJump (JumpTo JumpInfo blk
badJumpInfo) ->
case ChainSyncJumpingJumperState blk
jumperState of
LookingForIntersection JumpInfo blk
goodJumpInfo JumpInfo blk
_ ->
StrictTVar m (Maybe (JumpInfo blk))
-> JumpInfo blk
-> JumpInfo blk
-> STM m (Maybe (TraceEventCsj peer blk))
lookForIntersection StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar JumpInfo blk
goodJumpInfo JumpInfo blk
badJumpInfo
Happy JumperInitState
StartedJumper Maybe (JumpInfo blk)
mGoodJumpInfo ->
StrictTVar m (Maybe (JumpInfo blk))
-> JumpInfo blk
-> JumpInfo blk
-> STM m (Maybe (TraceEventCsj peer blk))
lookForIntersection StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar (Maybe (JumpInfo blk) -> JumpInfo blk -> JumpInfo blk
mkGoodJumpInfo Maybe (JumpInfo blk)
mGoodJumpInfo JumpInfo blk
badJumpInfo) JumpInfo blk
badJumpInfo
Happy JumperInitState
FreshJumper Maybe (JumpInfo blk)
_ ->
Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
FoundIntersection{} ->
String -> STM m (Maybe (TraceEventCsj peer blk))
forall a. HasCallStack => String -> a
error String
"processJumpResult (rejected): Jumpers in state FoundIntersection shouldn't be further jumping."
AcceptedJump JumpToGoodPoint{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
RejectedJump JumpToGoodPoint{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
where
blk -> HeaderFields blk
_ = forall b. HasHeader b => b -> HeaderFields b
getHeaderFields @blk
updateChainSyncState :: ChainSyncClientHandle m blk -> JumpInfo blk -> STM m ()
updateChainSyncState :: ChainSyncClientHandle m blk -> JumpInfo blk -> STM m ()
updateChainSyncState ChainSyncClientHandle m blk
handle JumpInfo blk
jump = do
let fragment :: AnchoredFragment (HeaderWithTime blk)
fragment = JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
jump
StrictTVar m (ChainSyncState blk)
-> (ChainSyncState blk -> ChainSyncState blk) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
cschState ChainSyncClientHandle m blk
handle) ((ChainSyncState blk -> ChainSyncState blk) -> STM m ())
-> (ChainSyncState blk -> ChainSyncState blk) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \ChainSyncState blk
csState ->
ChainSyncState blk
csState {csCandidate = fragment, csLatestSlot = SJust (AF.headSlot fragment) }
StrictTVar m (Maybe (JumpInfo blk))
-> Maybe (JumpInfo blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo ChainSyncClientHandle m blk
handle) (Maybe (JumpInfo blk) -> STM m ())
-> Maybe (JumpInfo blk) -> STM m ()
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> Maybe (JumpInfo blk)
forall a. a -> Maybe a
Just JumpInfo blk
jump
mkGoodJumpInfo :: Maybe (JumpInfo blk) -> JumpInfo blk -> JumpInfo blk
mkGoodJumpInfo :: Maybe (JumpInfo blk) -> JumpInfo blk -> JumpInfo blk
mkGoodJumpInfo Maybe (JumpInfo blk)
mGoodJumpInfo JumpInfo blk
badJumpInfo = do
let badFragment :: AnchoredFragment (HeaderWithTime blk)
badFragment = JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
badJumpInfo
badFragmentStart :: AnchoredFragment (HeaderWithTime blk)
badFragmentStart = Int
-> AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk)
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.takeOldest Int
0 AnchoredFragment (HeaderWithTime blk)
badFragment
in JumpInfo blk -> Maybe (JumpInfo blk) -> JumpInfo blk
forall a. a -> Maybe a -> a
fromMaybe (JumpInfo blk
badJumpInfo {jTheirFragment = badFragmentStart}) Maybe (JumpInfo blk)
mGoodJumpInfo
lookForIntersection :: StrictTVar m (Maybe (JumpInfo blk))
-> JumpInfo blk
-> JumpInfo blk
-> STM m (Maybe (TraceEventCsj peer blk))
lookForIntersection StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar JumpInfo blk
goodJumpInfo JumpInfo blk
badJumpInfo = do
let badFragment :: AnchoredFragment (HeaderWithTime blk)
badFragment = JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
badJumpInfo
searchFragment :: AnchoredFragment (HeaderWithTime blk)
searchFragment =
AnchoredFragment (HeaderWithTime blk)
-> ((AnchoredFragment (HeaderWithTime blk),
AnchoredFragment (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk))
-> Maybe
(AnchoredFragment (HeaderWithTime blk),
AnchoredFragment (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AnchoredFragment (HeaderWithTime blk)
badFragment (AnchoredFragment (HeaderWithTime blk),
AnchoredFragment (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
forall a b. (a, b) -> b
snd (Maybe
(AnchoredFragment (HeaderWithTime blk),
AnchoredFragment (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk))
-> Maybe
(AnchoredFragment (HeaderWithTime blk),
AnchoredFragment (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$
AnchoredFragment (HeaderWithTime blk)
-> Point (HeaderWithTime blk)
-> Maybe
(AnchoredFragment (HeaderWithTime blk),
AnchoredFragment (HeaderWithTime blk))
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
AF.splitAfterPoint AnchoredFragment (HeaderWithTime blk)
badFragment (AnchoredFragment (HeaderWithTime blk) -> Point (HeaderWithTime blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (HeaderWithTime blk)
-> Point (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
-> Point (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
goodJumpInfo)
let len :: Int
len = AnchoredFragment (HeaderWithTime blk) -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment (HeaderWithTime blk)
searchFragment
if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then do
StrictTVar m (Maybe (JumpInfo blk))
-> Maybe (JumpInfo blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar Maybe (JumpInfo blk)
forall a. Maybe a
Nothing
StrictTVar m (Maybe (JumpInfo blk))
-> JumpInfo blk
-> Point (Header blk)
-> STM m (Maybe (TraceEventCsj peer blk))
maybeElectNewObjector StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar JumpInfo blk
goodJumpInfo (Point (HeaderWithTime blk) -> Point (Header blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
AF.castPoint (Point (HeaderWithTime blk) -> Point (Header blk))
-> Point (HeaderWithTime blk) -> Point (Header blk)
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (HeaderWithTime blk) -> Point (HeaderWithTime blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (HeaderWithTime blk)
badFragment)
else do
let theirFragment :: AnchoredFragment (HeaderWithTime blk)
theirFragment = Int
-> AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk)
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropNewest (Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) AnchoredFragment (HeaderWithTime blk)
badFragment
StrictTVar m (Maybe (JumpInfo blk))
-> Maybe (JumpInfo blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar (Maybe (JumpInfo blk) -> STM m ())
-> Maybe (JumpInfo blk) -> STM m ()
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> Maybe (JumpInfo blk)
forall a. a -> Maybe a
Just
JumpInfo blk
badJumpInfo { jTheirFragment = theirFragment }
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (ChainSyncJumpingState m blk -> STM m ())
-> ChainSyncJumpingState m blk -> STM m ()
forall a b. (a -> b) -> a -> b
$
StrictTVar m (Maybe (JumpInfo blk))
-> ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
StrictTVar m (Maybe (JumpInfo blk))
-> ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk
Jumper StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar (JumpInfo blk -> JumpInfo blk -> ChainSyncJumpingJumperState blk
forall blk.
JumpInfo blk -> JumpInfo blk -> ChainSyncJumpingJumperState blk
LookingForIntersection JumpInfo blk
goodJumpInfo JumpInfo blk
badJumpInfo)
Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
maybeElectNewObjector ::
StrictTVar m (Maybe (JumpInfo blk))
-> JumpInfo blk
-> Point (Header blk)
-> STM m (Maybe (TraceEventCsj peer blk))
maybeElectNewObjector :: StrictTVar m (Maybe (JumpInfo blk))
-> JumpInfo blk
-> Point (Header blk)
-> STM m (Maybe (TraceEventCsj peer blk))
maybeElectNewObjector StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar JumpInfo blk
goodJumpInfo Point (Header blk)
badPoint = do
Context m peer blk
-> STM
m
(Maybe
(peer, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk
-> STM
m
(Maybe
(peer, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
findObjector (PeerContext m peer blk -> Context m peer blk
forall (m :: * -> *) peer blk.
PeerContext m peer blk -> Context m peer blk
stripContext PeerContext m peer blk
context) STM
m
(Maybe
(peer, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
-> (Maybe
(peer, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)
-> STM m (Maybe (TraceEventCsj peer blk)))
-> STM m (Maybe (TraceEventCsj peer 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
Maybe
(peer, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)
Nothing -> do
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingState m blk
Objector ObjectorInitState
Starting JumpInfo blk
goodJumpInfo Point (Header blk)
badPoint)
Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk)))
-> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a b. (a -> b) -> a -> b
$ TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a b. (a -> b) -> a -> b
$ Maybe peer -> TraceEventCsj peer blk
forall peer blk. Maybe peer -> TraceEventCsj peer blk
BecomingObjector Maybe peer
forall a. Maybe a
Nothing
Just (peer
oPeerId, ObjectorInitState
oInitState, JumpInfo blk
oGoodJump, Point (Header blk)
oBadPoint, ChainSyncClientHandle m blk
oHandle)
| Point (Header blk) -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point (Header blk)
oBadPoint WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= Point (Header blk) -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point (Header blk)
badPoint -> do
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (ChainSyncJumpingState m blk -> STM m ())
-> ChainSyncJumpingState m blk -> STM m ()
forall a b. (a -> b) -> a -> b
$
StrictTVar m (Maybe (JumpInfo blk))
-> ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
StrictTVar m (Maybe (JumpInfo blk))
-> ChainSyncJumpingJumperState blk -> ChainSyncJumpingState m blk
Jumper StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar (ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingJumperState blk
forall blk.
ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingJumperState blk
FoundIntersection ObjectorInitState
Starting JumpInfo blk
goodJumpInfo Point (Header blk)
badPoint)
Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
| Bool
otherwise -> do
Maybe (JumpInfo blk)
-> ChainSyncJumpingJumperState blk
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
(MonadSTM m, LedgerSupportsProtocol blk) =>
Maybe (JumpInfo blk)
-> ChainSyncJumpingJumperState blk
-> STM m (ChainSyncJumpingState m blk)
newJumper Maybe (JumpInfo blk)
forall a. Maybe a
Nothing (ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingJumperState blk
forall blk.
ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingJumperState blk
FoundIntersection ObjectorInitState
oInitState JumpInfo blk
oGoodJump Point (Header blk)
oBadPoint) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk -> STM m ()) -> STM m ()
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
>>=
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
oHandle)
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingState m blk
Objector ObjectorInitState
Starting JumpInfo blk
goodJumpInfo Point (Header blk)
badPoint)
Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk)))
-> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a b. (a -> b) -> a -> b
$ TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a b. (a -> b) -> a -> b
$ Maybe peer -> TraceEventCsj peer blk
forall peer blk. Maybe peer -> TraceEventCsj peer blk
BecomingObjector (peer -> Maybe peer
forall a. a -> Maybe a
Just peer
oPeerId)
updateJumpInfo ::
(MonadSTM m) =>
PeerContext m peer blk ->
JumpInfo blk ->
STM m ()
updateJumpInfo :: forall (m :: * -> *) peer blk.
MonadSTM m =>
PeerContext m peer blk -> JumpInfo blk -> STM m ()
updateJumpInfo PeerContext m peer blk
context JumpInfo blk
jumpInfo =
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk -> STM m ()) -> STM m ()
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
Disengaged{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ChainSyncJumpingState m blk
_ -> StrictTVar m (Maybe (JumpInfo blk))
-> Maybe (JumpInfo blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) (Maybe (JumpInfo blk) -> STM m ())
-> Maybe (JumpInfo blk) -> STM m ()
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> Maybe (JumpInfo blk)
forall a. a -> Maybe a
Just JumpInfo blk
jumpInfo
getDynamo ::
(MonadSTM m) =>
ChainSyncClientHandleCollection peer m blk ->
STM m (Maybe (peer, ChainSyncClientHandle m blk))
getDynamo :: forall (m :: * -> *) peer blk.
MonadSTM m =>
ChainSyncClientHandleCollection peer m blk
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
getDynamo ChainSyncClientHandleCollection peer m blk
handlesCol = do
handles <- ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
cschcSeq ChainSyncClientHandleCollection peer m blk
handlesCol
findM (\(peer
_, ChainSyncClientHandle m blk
handle) -> ChainSyncJumpingState m blk -> Bool
forall {m :: * -> *} {blk}. ChainSyncJumpingState m blk -> Bool
isDynamo (ChainSyncJumpingState m blk -> Bool)
-> STM m (ChainSyncJumpingState m blk) -> STM m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
handle)) handles
where
isDynamo :: ChainSyncJumpingState m blk -> Bool
isDynamo Dynamo{} = Bool
True
isDynamo ChainSyncJumpingState m blk
_ = Bool
False
disengage :: MonadSTM m => ChainSyncClientHandle m blk -> STM m ()
disengage :: forall (m :: * -> *) blk.
MonadSTM m =>
ChainSyncClientHandle m blk -> STM m ()
disengage = DisengagedInitState -> ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) blk.
MonadSTM m =>
DisengagedInitState -> ChainSyncClientHandle m blk -> STM m ()
disengageWith DisengagedInitState
DisengagedDone
startDisengaging :: MonadSTM m => ChainSyncClientHandle m blk -> STM m ()
startDisengaging :: forall (m :: * -> *) blk.
MonadSTM m =>
ChainSyncClientHandle m blk -> STM m ()
startDisengaging = DisengagedInitState -> ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) blk.
MonadSTM m =>
DisengagedInitState -> ChainSyncClientHandle m blk -> STM m ()
disengageWith DisengagedInitState
Disengaging
disengageWith ::
MonadSTM m =>
DisengagedInitState ->
ChainSyncClientHandle m blk ->
STM m ()
disengageWith :: forall (m :: * -> *) blk.
MonadSTM m =>
DisengagedInitState -> ChainSyncClientHandle m blk -> STM m ()
disengageWith DisengagedInitState
initState ChainSyncClientHandle m blk
handle = do
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
handle) (DisengagedInitState -> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
DisengagedInitState -> ChainSyncJumpingState m blk
Disengaged DisengagedInitState
initState)
StrictTVar m (Maybe (JumpInfo blk))
-> Maybe (JumpInfo blk) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo ChainSyncClientHandle m blk
handle) Maybe (JumpInfo blk)
forall a. Maybe a
Nothing
newJumper ::
( MonadSTM m,
LedgerSupportsProtocol blk
) =>
Maybe (JumpInfo blk) ->
ChainSyncJumpingJumperState blk ->
STM m (ChainSyncJumpingState m blk)
newJumper :: forall (m :: * -> *) blk.
(MonadSTM m, LedgerSupportsProtocol blk) =>
Maybe (JumpInfo blk)
-> ChainSyncJumpingJumperState blk
-> STM m (ChainSyncJumpingState m blk)
newJumper Maybe (JumpInfo blk)
jumpInfo ChainSyncJumpingJumperState blk
jumperState = do
nextJumpVar <- Maybe (JumpInfo blk) -> STM m (StrictTVar m (Maybe (JumpInfo blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> STM m (StrictTVar m a)
newTVar Maybe (JumpInfo blk)
jumpInfo
pure $ Jumper nextJumpVar jumperState
registerClient ::
( LedgerSupportsProtocol blk,
IOLike m
) =>
GsmState ->
Context m peer blk ->
peer ->
StrictTVar m (ChainSyncState blk) ->
(StrictTVar m (ChainSyncJumpingState m blk) -> ChainSyncClientHandle m blk) ->
STM m (PeerContext m peer blk, Maybe (TraceEventCsj peer blk))
registerClient :: forall blk (m :: * -> *) peer.
(LedgerSupportsProtocol blk, IOLike m) =>
GsmState
-> Context m peer blk
-> peer
-> StrictTVar m (ChainSyncState blk)
-> (StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncClientHandle m blk)
-> STM m (PeerContext m peer blk, Maybe (TraceEventCsj peer blk))
registerClient GsmState
gsmState Context m peer blk
context peer
peer StrictTVar m (ChainSyncState blk)
csState StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncClientHandle m blk
mkHandle = do
(csjState, mbEv) <- case GsmState
gsmState of
GsmState
GSM.CaughtUp -> (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer blk))
-> STM
m (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DisengagedInitState -> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
DisengagedInitState -> ChainSyncJumpingState m blk
Disengaged DisengagedInitState
DisengagedDone, Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing)
GsmState
GSM.PreSyncing -> Context m peer blk
-> StrictTVar m (ChainSyncState blk)
-> STM
m (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer blk))
forall blk (m :: * -> *) peer.
(LedgerSupportsProtocol blk, IOLike m) =>
Context m peer blk
-> StrictTVar m (ChainSyncState blk)
-> STM
m (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer blk))
engageClient Context m peer blk
context StrictTVar m (ChainSyncState blk)
csState
GsmState
GSM.Syncing -> Context m peer blk
-> StrictTVar m (ChainSyncState blk)
-> STM
m (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer blk))
forall blk (m :: * -> *) peer.
(LedgerSupportsProtocol blk, IOLike m) =>
Context m peer blk
-> StrictTVar m (ChainSyncState blk)
-> STM
m (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer blk))
engageClient Context m peer blk
context StrictTVar m (ChainSyncState blk)
csState
cschJumping <- newTVar csjState
let handle = StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncClientHandle m blk
mkHandle StrictTVar m (ChainSyncJumpingState m blk)
cschJumping
cschcAddHandle (handlesCol context) peer handle
pure (context {peer, handle}, mbEv)
engageClient ::
( LedgerSupportsProtocol blk,
IOLike m
) =>
Context m peer blk ->
StrictTVar m (ChainSyncState blk) ->
STM m (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer blk))
engageClient :: forall blk (m :: * -> *) peer.
(LedgerSupportsProtocol blk, IOLike m) =>
Context m peer blk
-> StrictTVar m (ChainSyncState blk)
-> STM
m (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer blk))
engageClient Context m peer blk
context StrictTVar m (ChainSyncState blk)
csState = do
ChainSyncClientHandleCollection peer m blk
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
forall (m :: * -> *) peer blk.
MonadSTM m =>
ChainSyncClientHandleCollection peer m blk
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
getDynamo (Context m peer blk -> ChainSyncClientHandleCollection peer m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> ChainSyncClientHandleCollection peer m blk
handlesCol Context m peer blk
context) STM m (Maybe (peer, ChainSyncClientHandle m blk))
-> (Maybe (peer, ChainSyncClientHandle m blk)
-> STM
m (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer blk)))
-> STM
m (ChainSyncJumpingState m blk, Maybe (TraceEventCsj peer 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
Maybe (peer, ChainSyncClientHandle m blk)
Nothing -> do
fragment <- ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk)
forall blk.
ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk)
csCandidate (ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk))
-> STM m (ChainSyncState blk)
-> STM m (AnchoredFragment (HeaderWithTime blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (ChainSyncState blk) -> STM m (ChainSyncState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainSyncState blk)
csState
pure (Dynamo DynamoStarted $ pointSlot $ AF.anchorPoint fragment, Just InitializedAsDynamo)
Just (peer
_, ChainSyncClientHandle m blk
handle) -> do
mJustInfo <- StrictTVar m (Maybe (JumpInfo blk)) -> STM m (Maybe (JumpInfo blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo ChainSyncClientHandle m blk
handle)
(\ChainSyncJumpingState m blk
x -> (ChainSyncJumpingState m blk
x, Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing)) <$> newJumper mJustInfo (Happy FreshJumper Nothing)
unregisterClient ::
( MonadSTM m,
Ord peer,
LedgerSupportsProtocol blk
) =>
PeerContext m peer blk ->
STM m (Maybe (TraceEventCsj peer blk))
unregisterClient :: forall (m :: * -> *) peer blk.
(MonadSTM m, Ord peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> STM m (Maybe (TraceEventCsj peer blk))
unregisterClient PeerContext m peer blk
context = do
ChainSyncClientHandleCollection peer m blk -> peer -> STM m ()
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk -> peer -> STM m ()
cschcRemoveHandle (PeerContext m peer blk
-> ChainSyncClientHandleCollection peer m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> ChainSyncClientHandleCollection peer m blk
handlesCol PeerContext m peer blk
context) (PeerContext m peer blk -> peer
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> peerField
peer PeerContext m peer blk
context)
let context' :: Context m peer blk
context' = PeerContext m peer blk -> Context m peer blk
forall (m :: * -> *) peer blk.
PeerContext m peer blk -> Context m peer blk
stripContext PeerContext m peer blk
context
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping (PeerContext m peer blk -> ChainSyncClientHandle m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> handleField
handle PeerContext m peer blk
context)) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk
-> STM m (Maybe (TraceEventCsj peer blk)))
-> STM m (Maybe (TraceEventCsj peer 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
Disengaged{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Jumper{} -> Maybe (TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventCsj peer blk)
forall a. Maybe a
Nothing
Objector{} -> (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk)
-> Maybe (TraceEventCsj peer blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a -> b) -> a -> b
$ TraceCsjReason
BecauseCsjDisconnect)) ((TraceCsjReason -> TraceEventCsj peer blk)
-> Maybe (TraceEventCsj peer blk))
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
-> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
electNewObjector Context m peer blk
context'
Dynamo{} -> (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk)
forall a. a -> Maybe a
Just (TraceEventCsj peer blk -> Maybe (TraceEventCsj peer blk))
-> ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> Maybe (TraceEventCsj peer blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a -> b) -> a -> b
$ TraceCsjReason
BecauseCsjDisconnect) ((TraceCsjReason -> TraceEventCsj peer blk)
-> TraceEventCsj peer blk)
-> ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceCsjReason -> TraceEventCsj peer blk)
-> (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceEventCsj peer blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> TraceCsjReason -> TraceEventCsj peer blk
forall a b. (a, b) -> a
fst) ((TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> Maybe (TraceEventCsj peer blk))
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> STM m (Maybe (TraceEventCsj peer blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context m peer blk
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
Context m peer blk
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
backfillDynamo Context m peer blk
context'
rotateDynamo ::
( Ord peer,
LedgerSupportsProtocol blk,
MonadSTM m
) =>
Tracer m (TraceEventDbf peer) ->
ChainSyncClientHandleCollection peer m blk ->
peer ->
m ()
rotateDynamo :: forall peer blk (m :: * -> *).
(Ord peer, LedgerSupportsProtocol blk, MonadSTM m) =>
Tracer m (TraceEventDbf peer)
-> ChainSyncClientHandleCollection peer m blk -> peer -> m ()
rotateDynamo Tracer m (TraceEventDbf peer)
tracer ChainSyncClientHandleCollection peer m blk
handlesCol peer
peer = do
traceEvent <- STM m (Maybe (TraceEventDbf peer))
-> m (Maybe (TraceEventDbf peer))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (TraceEventDbf peer))
-> m (Maybe (TraceEventDbf peer)))
-> STM m (Maybe (TraceEventDbf peer))
-> m (Maybe (TraceEventDbf peer))
forall a b. (a -> b) -> a -> b
$ do
handles <- ChainSyncClientHandleCollection peer m blk
-> STM m (Map peer (ChainSyncClientHandle m blk))
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk
-> STM m (Map peer (ChainSyncClientHandle m blk))
cschcMap ChainSyncClientHandleCollection peer m blk
handlesCol
case handles Map.!? peer of
Maybe (ChainSyncClientHandle m blk)
Nothing ->
Maybe (TraceEventDbf peer) -> STM m (Maybe (TraceEventDbf peer))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventDbf peer)
forall a. Maybe a
Nothing
Just ChainSyncClientHandle m blk
oldDynHandle ->
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
oldDynHandle) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk
-> STM m (Maybe (TraceEventDbf peer)))
-> STM m (Maybe (TraceEventDbf peer))
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
Dynamo{} -> do
ChainSyncClientHandleCollection peer m blk -> peer -> STM m ()
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk -> peer -> STM m ()
cschcRotateHandle ChainSyncClientHandleCollection peer m blk
handlesCol peer
peer
peerStates <- ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
cschcSeq ChainSyncClientHandleCollection peer m blk
handlesCol
mEngaged <- findNonDisengaged peerStates
case mEngaged of
Maybe (peer, ChainSyncClientHandle m blk)
Nothing ->
String -> STM m (Maybe (TraceEventDbf peer))
forall a. HasCallStack => String -> a
error String
"rotateDynamo: no engaged peer found"
Just (peer
newDynamoId, ChainSyncClientHandle m blk
newDynHandle)
| peer
newDynamoId peer -> peer -> Bool
forall a. Eq a => a -> a -> Bool
== peer
peer ->
Maybe (TraceEventDbf peer) -> STM m (Maybe (TraceEventDbf peer))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventDbf peer)
forall a. Maybe a
Nothing
| Bool
otherwise -> do
Maybe (JumpInfo blk)
-> ChainSyncJumpingJumperState blk
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
(MonadSTM m, LedgerSupportsProtocol blk) =>
Maybe (JumpInfo blk)
-> ChainSyncJumpingJumperState blk
-> STM m (ChainSyncJumpingState m blk)
newJumper Maybe (JumpInfo blk)
forall a. Maybe a
Nothing (JumperInitState
-> Maybe (JumpInfo blk) -> ChainSyncJumpingJumperState blk
forall blk.
JumperInitState
-> Maybe (JumpInfo blk) -> ChainSyncJumpingJumperState blk
Happy JumperInitState
FreshJumper Maybe (JumpInfo blk)
forall a. Maybe a
Nothing)
STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk -> STM m ()) -> STM m ()
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
>>= StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
oldDynHandle)
StrictSeq (peer, ChainSyncClientHandle m blk)
-> peer -> ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
StrictSeq (peer, ChainSyncClientHandle m blk)
-> peer -> ChainSyncClientHandle m blk -> STM m ()
promoteToDynamo StrictSeq (peer, ChainSyncClientHandle m blk)
peerStates peer
newDynamoId ChainSyncClientHandle m blk
newDynHandle
Maybe (TraceEventDbf peer) -> STM m (Maybe (TraceEventDbf peer))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TraceEventDbf peer) -> STM m (Maybe (TraceEventDbf peer)))
-> Maybe (TraceEventDbf peer) -> STM m (Maybe (TraceEventDbf peer))
forall a b. (a -> b) -> a -> b
$ TraceEventDbf peer -> Maybe (TraceEventDbf peer)
forall a. a -> Maybe a
Just (TraceEventDbf peer -> Maybe (TraceEventDbf peer))
-> TraceEventDbf peer -> Maybe (TraceEventDbf peer)
forall a b. (a -> b) -> a -> b
$ peer -> peer -> TraceEventDbf peer
forall peer. peer -> peer -> TraceEventDbf peer
RotatedDynamo peer
peer peer
newDynamoId
ChainSyncJumpingState m blk
_ ->
Maybe (TraceEventDbf peer) -> STM m (Maybe (TraceEventDbf peer))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TraceEventDbf peer)
forall a. Maybe a
Nothing
traverse_ (traceWith tracer) traceEvent
backfillDynamo ::
( MonadSTM m,
Eq peer,
LedgerSupportsProtocol blk
) =>
Context m peer blk ->
STM m (TraceCsjReason -> TraceEventCsj peer blk, Maybe (peer, ChainSyncClientHandle m blk))
backfillDynamo :: forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
Context m peer blk
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
backfillDynamo Context m peer blk
context = do
peerStates <- ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
cschcSeq (Context m peer blk -> ChainSyncClientHandleCollection peer m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> ChainSyncClientHandleCollection peer m blk
handlesCol Context m peer blk
context)
mDynamo <- do
findObjector context >>= \case
Just (peer
oId, ObjectorInitState
Started, JumpInfo blk
_oGoodJI, Point (Header blk)
_oBad, ChainSyncClientHandle m blk
oHandle) ->
Maybe (peer, ChainSyncClientHandle m blk)
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (peer, ChainSyncClientHandle m blk)
-> STM m (Maybe (peer, ChainSyncClientHandle m blk)))
-> Maybe (peer, ChainSyncClientHandle m blk)
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
forall a b. (a -> b) -> a -> b
$ (peer, ChainSyncClientHandle m blk)
-> Maybe (peer, ChainSyncClientHandle m blk)
forall a. a -> Maybe a
Just ((peer, ChainSyncClientHandle m blk)
-> Maybe (peer, ChainSyncClientHandle m blk))
-> (peer, ChainSyncClientHandle m blk)
-> Maybe (peer, ChainSyncClientHandle m blk)
forall a b. (a -> b) -> a -> b
$ (peer
oId,ChainSyncClientHandle m blk
oHandle)
Maybe
(peer, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)
_ ->
StrictSeq (peer, ChainSyncClientHandle m blk)
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
forall (m :: * -> *) peer blk.
MonadSTM m =>
StrictSeq (peer, ChainSyncClientHandle m blk)
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
findNonDisengaged StrictSeq (peer, ChainSyncClientHandle m blk)
peerStates
case mDynamo of
Maybe (peer, ChainSyncClientHandle m blk)
Nothing -> (TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe peer -> TraceCsjReason -> TraceEventCsj peer blk
forall peer blk.
Maybe peer -> TraceCsjReason -> TraceEventCsj peer blk
NoLongerDynamo Maybe peer
forall a. Maybe a
Nothing, Maybe (peer, ChainSyncClientHandle m blk)
forall a. Maybe a
Nothing)
Just (peer
dynId, ChainSyncClientHandle m blk
dynamo) -> do
StrictSeq (peer, ChainSyncClientHandle m blk)
-> peer -> ChainSyncClientHandle m blk -> STM m ()
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
StrictSeq (peer, ChainSyncClientHandle m blk)
-> peer -> ChainSyncClientHandle m blk -> STM m ()
promoteToDynamo StrictSeq (peer, ChainSyncClientHandle m blk)
peerStates peer
dynId ChainSyncClientHandle m blk
dynamo
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
-> STM
m
(TraceCsjReason -> TraceEventCsj peer blk,
Maybe (peer, ChainSyncClientHandle m blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe peer -> TraceCsjReason -> TraceEventCsj peer blk
forall peer blk.
Maybe peer -> TraceCsjReason -> TraceEventCsj peer blk
NoLongerDynamo (peer -> Maybe peer
forall a. a -> Maybe a
Just peer
dynId), (peer, ChainSyncClientHandle m blk)
-> Maybe (peer, ChainSyncClientHandle m blk)
forall a. a -> Maybe a
Just (peer
dynId, ChainSyncClientHandle m blk
dynamo))
promoteToDynamo ::
( MonadSTM m,
Eq peer,
LedgerSupportsProtocol blk
) =>
StrictSeq (peer, ChainSyncClientHandle m blk) ->
peer ->
ChainSyncClientHandle m blk ->
STM m ()
promoteToDynamo :: forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
StrictSeq (peer, ChainSyncClientHandle m blk)
-> peer -> ChainSyncClientHandle m blk -> STM m ()
promoteToDynamo StrictSeq (peer, ChainSyncClientHandle m blk)
peerStates peer
dynId ChainSyncClientHandle m blk
dynamo = do
mJumpInfo <- StrictTVar m (Maybe (JumpInfo blk)) -> STM m (Maybe (JumpInfo blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo ChainSyncClientHandle m blk
dynamo)
jumping' <- readTVar (cschJumping dynamo) >>= \case
Objector ObjectorInitState
Started JumpInfo blk
oGoodJI Point (Header blk)
_oBad -> do
let islot :: WithOrigin SlotNo
islot = AnchoredFragment (HeaderWithTime blk) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot (AnchoredFragment (HeaderWithTime blk) -> WithOrigin SlotNo)
-> AnchoredFragment (HeaderWithTime blk) -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
oGoodJI
ChainSyncJumpingState m blk -> STM m (ChainSyncJumpingState m blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainSyncJumpingState m blk
-> STM m (ChainSyncJumpingState m blk))
-> ChainSyncJumpingState m blk
-> STM m (ChainSyncJumpingState m blk)
forall a b. (a -> b) -> a -> b
$ DynamoInitState blk
-> WithOrigin SlotNo -> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
DynamoInitState blk
-> WithOrigin SlotNo -> ChainSyncJumpingState m blk
Dynamo DynamoInitState blk
forall blk. DynamoInitState blk
DynamoStarted WithOrigin SlotNo
islot
ChainSyncJumpingState m blk
_ -> do
fragment <- ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk)
forall blk.
ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk)
csCandidate (ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk))
-> STM m (ChainSyncState blk)
-> STM m (AnchoredFragment (HeaderWithTime blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (ChainSyncState blk) -> STM m (ChainSyncState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
cschState ChainSyncClientHandle m blk
dynamo)
let dynamoInitState = DynamoInitState blk
-> (JumpInfo blk -> DynamoInitState blk)
-> Maybe (JumpInfo blk)
-> DynamoInitState blk
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DynamoInitState blk
forall blk. DynamoInitState blk
DynamoStarted JumpInfo blk -> DynamoInitState blk
forall blk. JumpInfo blk -> DynamoInitState blk
DynamoStarting Maybe (JumpInfo blk)
mJumpInfo
slot = AnchoredFragment (HeaderWithTime blk) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot AnchoredFragment (HeaderWithTime blk)
fragment
pure $ Dynamo dynamoInitState slot
writeTVar (cschJumping dynamo) jumping'
forM_ peerStates $ \(peer
peer, ChainSyncClientHandle m blk
st) ->
Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (peer
peer peer -> peer -> Bool
forall a. Eq a => a -> a -> Bool
/= peer
dynId) (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$ do
jumpingState <- StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
st)
when (not (isDisengaged jumpingState)) $
newJumper mJumpInfo (Happy FreshJumper Nothing)
>>= writeTVar (cschJumping st)
findNonDisengaged ::
(MonadSTM m) =>
StrictSeq (peer, ChainSyncClientHandle m blk) ->
STM m (Maybe (peer, ChainSyncClientHandle m blk))
findNonDisengaged :: forall (m :: * -> *) peer blk.
MonadSTM m =>
StrictSeq (peer, ChainSyncClientHandle m blk)
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
findNonDisengaged =
((peer, ChainSyncClientHandle m blk) -> STM m Bool)
-> StrictSeq (peer, ChainSyncClientHandle m blk)
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m (Maybe a)
findM (((peer, ChainSyncClientHandle m blk) -> STM m Bool)
-> StrictSeq (peer, ChainSyncClientHandle m blk)
-> STM m (Maybe (peer, ChainSyncClientHandle m blk)))
-> ((peer, ChainSyncClientHandle m blk) -> STM m Bool)
-> StrictSeq (peer, ChainSyncClientHandle m blk)
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
forall a b. (a -> b) -> a -> b
$ \(peer
_, ChainSyncClientHandle m blk
st) -> Bool -> Bool
not (Bool -> Bool)
-> (ChainSyncJumpingState m blk -> Bool)
-> ChainSyncJumpingState m blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainSyncJumpingState m blk -> Bool
forall {m :: * -> *} {blk}. ChainSyncJumpingState m blk -> Bool
isDisengaged (ChainSyncJumpingState m blk -> Bool)
-> STM m (ChainSyncJumpingState m blk) -> STM m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
st)
isDisengaged :: ChainSyncJumpingState m blk -> Bool
isDisengaged :: forall {m :: * -> *} {blk}. ChainSyncJumpingState m blk -> Bool
isDisengaged Disengaged{} = Bool
True
isDisengaged ChainSyncJumpingState m blk
_ = Bool
False
findObjector ::
(MonadSTM m) =>
Context m peer blk ->
STM m (Maybe (peer, ObjectorInitState, JumpInfo blk, Point (Header blk), ChainSyncClientHandle m blk))
findObjector :: forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk
-> STM
m
(Maybe
(peer, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
findObjector Context m peer blk
context =
ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
cschcSeq (Context m peer blk -> ChainSyncClientHandleCollection peer m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> ChainSyncClientHandleCollection peer m blk
handlesCol Context m peer blk
context) STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
-> (StrictSeq (peer, ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(peer, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)))
-> STM
m
(Maybe
(peer, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle 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
>>= StrictSeq (peer, ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(peer, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
forall {m :: * -> *} {a} {blk}.
MonadSTM m =>
StrictSeq (a, ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
go
where
go :: StrictSeq (a, ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
go StrictSeq (a, ChainSyncClientHandle m blk)
Seq.Empty = Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)
forall a. Maybe a
Nothing
go ((a
peer, ChainSyncClientHandle m blk
handle) Seq.:<| StrictSeq (a, ChainSyncClientHandle m blk)
xs) =
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
handle) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk
-> STM
m
(Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)))
-> STM
m
(Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle 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
Objector ObjectorInitState
initState JumpInfo blk
goodJump Point (Header blk)
badPoint ->
Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)))
-> Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
forall a b. (a -> b) -> a -> b
$ (a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)
-> Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk)
forall a. a -> Maybe a
Just (a
peer, ObjectorInitState
initState, JumpInfo blk
goodJump, Point (Header blk)
badPoint, ChainSyncClientHandle m blk
handle)
ChainSyncJumpingState m blk
_ -> StrictSeq (a, ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(a, ObjectorInitState, JumpInfo blk, Point (Header blk),
ChainSyncClientHandle m blk))
go StrictSeq (a, ChainSyncClientHandle m blk)
xs
electNewObjector ::
(MonadSTM m) =>
Context m peer blk ->
STM m (TraceCsjReason -> TraceEventCsj peer blk)
electNewObjector :: forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
electNewObjector Context m peer blk
context = Maybe peer -> TraceCsjReason -> TraceEventCsj peer blk
forall peer blk.
Maybe peer -> TraceCsjReason -> TraceEventCsj peer blk
NoLongerObjector (Maybe peer -> TraceCsjReason -> TraceEventCsj peer blk)
-> STM m (Maybe peer)
-> STM m (TraceCsjReason -> TraceEventCsj peer blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
peerStates <- StrictSeq (peer, ChainSyncClientHandle m blk)
-> [(peer, ChainSyncClientHandle m blk)]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (peer, ChainSyncClientHandle m blk)
-> [(peer, ChainSyncClientHandle m blk)])
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
-> STM m [(peer, ChainSyncClientHandle m blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk
-> STM m (StrictSeq (peer, ChainSyncClientHandle m blk))
cschcSeq (Context m peer blk -> ChainSyncClientHandleCollection peer m blk
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> ChainSyncClientHandleCollection peer m blk
handlesCol Context m peer blk
context)
dissentingJumpers <- collectDissentingJumpers peerStates
let sortedJumpers = ((peer,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> WithOrigin SlotNo)
-> [(peer,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
-> [(peer,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Point (Header blk) -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point (Header blk) -> WithOrigin SlotNo)
-> ((peer,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> Point (Header blk))
-> (peer,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
-> Point (Header blk)
forall a b. (a, b) -> a
fst ((Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
-> Point (Header blk))
-> ((peer,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> (Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> (peer,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> Point (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (peer,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> (Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
forall a b. (a, b) -> b
snd) [(peer,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
dissentingJumpers
case sortedJumpers of
[] -> Maybe peer -> STM m (Maybe peer)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe peer
forall a. Maybe a
Nothing
(peer
peer, (Point (Header blk)
badPoint, (ObjectorInitState
initState, JumpInfo blk
goodJumpInfo, ChainSyncClientHandle m blk
handle))):[(peer,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
_ -> do
StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncJumpingState m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
handle) (ChainSyncJumpingState m blk -> STM m ())
-> ChainSyncJumpingState m blk -> STM m ()
forall a b. (a -> b) -> a -> b
$ ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingState m blk
forall (m :: * -> *) blk.
ObjectorInitState
-> JumpInfo blk
-> Point (Header blk)
-> ChainSyncJumpingState m blk
Objector ObjectorInitState
initState JumpInfo blk
goodJumpInfo Point (Header blk)
badPoint
Maybe peer -> STM m (Maybe peer)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe peer -> STM m (Maybe peer))
-> Maybe peer -> STM m (Maybe peer)
forall a b. (a -> b) -> a -> b
$ peer -> Maybe peer
forall a. a -> Maybe a
Just peer
peer
where
collectDissentingJumpers :: [(a, ChainSyncClientHandle m blk)]
-> STM
m
[(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
collectDissentingJumpers [(a, ChainSyncClientHandle m blk)]
peerStates =
([Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
-> [(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))])
-> STM
m
[Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
-> STM
m
[(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m 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 [Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
-> [(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
forall a. [Maybe a] -> [a]
catMaybes (STM
m
[Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
-> STM
m
[(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))])
-> STM
m
[Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
-> STM
m
[(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
forall a b. (a -> b) -> a -> b
$
[(a, ChainSyncClientHandle m blk)]
-> ((a, ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))))
-> STM
m
[Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(a, ChainSyncClientHandle m blk)]
peerStates (((a, ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))))
-> STM
m
[Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))])
-> ((a, ChainSyncClientHandle m blk)
-> STM
m
(Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))))
-> STM
m
[Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))]
forall a b. (a -> b) -> a -> b
$ \(a
peer, ChainSyncClientHandle m blk
handle) ->
StrictTVar m (ChainSyncJumpingState m blk)
-> STM m (ChainSyncJumpingState m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk
-> StrictTVar m (ChainSyncJumpingState m blk)
cschJumping ChainSyncClientHandle m blk
handle) STM m (ChainSyncJumpingState m blk)
-> (ChainSyncJumpingState m blk
-> STM
m
(Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))))
-> STM
m
(Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle 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
Jumper StrictTVar m (Maybe (JumpInfo blk))
_ (FoundIntersection ObjectorInitState
initState JumpInfo blk
goodJumpInfo Point (Header blk)
badPoint) ->
Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> STM
m
(Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> STM
m
(Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))))
-> Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> STM
m
(Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))))
forall a b. (a -> b) -> a -> b
$ (a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
forall a. a -> Maybe a
Just (a
peer, (Point (Header blk)
badPoint, (ObjectorInitState
initState, JumpInfo blk
goodJumpInfo, ChainSyncClientHandle m blk
handle)))
ChainSyncJumpingState m blk
_ ->
Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
-> STM
m
(Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe
(a,
(Point (Header blk),
(ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
forall a. Maybe a
Nothing
data TraceEventDbf peer
= RotatedDynamo peer peer
deriving (Int -> TraceEventDbf peer -> ShowS
[TraceEventDbf peer] -> ShowS
TraceEventDbf peer -> String
(Int -> TraceEventDbf peer -> ShowS)
-> (TraceEventDbf peer -> String)
-> ([TraceEventDbf peer] -> ShowS)
-> Show (TraceEventDbf peer)
forall peer. Show peer => Int -> TraceEventDbf peer -> ShowS
forall peer. Show peer => [TraceEventDbf peer] -> ShowS
forall peer. Show peer => TraceEventDbf peer -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall peer. Show peer => Int -> TraceEventDbf peer -> ShowS
showsPrec :: Int -> TraceEventDbf peer -> ShowS
$cshow :: forall peer. Show peer => TraceEventDbf peer -> String
show :: TraceEventDbf peer -> String
$cshowList :: forall peer. Show peer => [TraceEventDbf peer] -> ShowS
showList :: [TraceEventDbf peer] -> ShowS
Show)
data TraceEventCsj peer blk
= BecomingObjector (Maybe peer)
| BlockedOnJump
| InitializedAsDynamo
| NoLongerDynamo (Maybe peer) TraceCsjReason
| NoLongerObjector (Maybe peer) TraceCsjReason
| SentJumpInstruction (Point blk)
deriving (Int -> TraceEventCsj peer blk -> ShowS
[TraceEventCsj peer blk] -> ShowS
TraceEventCsj peer blk -> String
(Int -> TraceEventCsj peer blk -> ShowS)
-> (TraceEventCsj peer blk -> String)
-> ([TraceEventCsj peer blk] -> ShowS)
-> Show (TraceEventCsj peer blk)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall peer blk.
(StandardHash blk, Show peer) =>
Int -> TraceEventCsj peer blk -> ShowS
forall peer blk.
(StandardHash blk, Show peer) =>
[TraceEventCsj peer blk] -> ShowS
forall peer blk.
(StandardHash blk, Show peer) =>
TraceEventCsj peer blk -> String
$cshowsPrec :: forall peer blk.
(StandardHash blk, Show peer) =>
Int -> TraceEventCsj peer blk -> ShowS
showsPrec :: Int -> TraceEventCsj peer blk -> ShowS
$cshow :: forall peer blk.
(StandardHash blk, Show peer) =>
TraceEventCsj peer blk -> String
show :: TraceEventCsj peer blk -> String
$cshowList :: forall peer blk.
(StandardHash blk, Show peer) =>
[TraceEventCsj peer blk] -> ShowS
showList :: [TraceEventCsj peer blk] -> ShowS
Show)
data TraceCsjReason
= BecauseCsjDisengage
| BecauseCsjDisconnect
deriving (Int -> TraceCsjReason -> ShowS
[TraceCsjReason] -> ShowS
TraceCsjReason -> String
(Int -> TraceCsjReason -> ShowS)
-> (TraceCsjReason -> String)
-> ([TraceCsjReason] -> ShowS)
-> Show TraceCsjReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceCsjReason -> ShowS
showsPrec :: Int -> TraceCsjReason -> ShowS
$cshow :: TraceCsjReason -> String
show :: TraceCsjReason -> String
$cshowList :: [TraceCsjReason] -> ShowS
showList :: [TraceCsjReason] -> ShowS
Show)
unitNothing :: () -> Maybe a
unitNothing :: forall a. () -> Maybe a
unitNothing () = Maybe a
forall a. Maybe a
Nothing