{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

-- | ChainSync jumping (CSJ) is an optimization for the ChainSync protocol that
-- allows nodes to sync without downloading headers from all of the honest
-- peers. This load is undesirable as it slows down all the peers involved.
--
-- The idea is to download the headers of a chain from a single peer (the
-- dynamo) and then ask periodically to the other peers (the jumpers) whether
-- they agree with the dynamo's chain.
--
-- When the jumpers disagree with the dynamo, the jumper with the oldest
-- intersection is asked to compete with the dynamo in the GDD logic (becoming
-- an objector). If the dynamo is disconnected, a new dynamo is elected and the
-- objector is demoted to a jumper.
--
-- If the objector is disconnected, the syncing process continues with the
-- dynamo and the remaining jumpers.
--
-- The main property of the algorithm is that it never
-- downloads headers from more than two plausibly honest peers at a time (a
-- dynamo and an objector). All other peers are either waiting their turn to
-- compete with the dynamo, or are in agreement with it, or are disengaged
-- (see next section).
--
-- The algorithm might still download headers redundantly from peers that do
-- historical rollbacks. These rollbacks, however, constitute dishonest
-- behavior, and CSJ does not concern itself with avoiding load to dishonest
-- peers. Avoiding the load induced by dishonest peers on the syncing node would
-- require additionally to disconnect peers that do historical rollbacks. This
-- is not done by CSJ.
--
-- Interactions with the Genesis Density Disconnection logic
-- ---------------------------------------------------------
--
-- It is possible that neither the dynamo nor the objector are disconnected.
-- This could happen if:
-- 1. They both serve the same chain, or
-- 2. They both claim to have no more headers.
--
-- To avoid (1) CSJ checks that the objector disagrees with the dynamo at the
-- point it claimed to disagree as a jumper. If the objector agrees with the
-- dynamo, it is disengaged. A disengaged peer is not asked to jump or act as
-- dynamo or objector. Instead, it continues to offer headers for the rest of
-- the syncing. When the objector is disengaged, a new objector is elected
-- among the dissenting jumpers. If there are no dissenting jumpers left, the
-- syncing continues with the dynamo and the remaining jumpers.
--
-- To prevent the dynamo from agreeing with the objector instead, the dynamo is
-- not allowed to rollback before the last jump it requested. If the dynamo
-- tries to rollback before the last jump, it is disengaged and a new dynamo is
-- elected.
--
-- To avoid (2) CSJ disengages a peer as soon as it claims to have no more
-- headers. Syncing continues with a new elected dynamo or objector depending on
-- the disengaged peer's role.
--
-- CSJ finishes and is turned off when all peers have been disengaged.
--
-- Interactions with the ChainSync client
-- --------------------------------------
--
-- The ChainSync client interacts with CSJ through some callbacks that determine
-- when the client should pause, download headers, or ask about agreement with
-- a given point (jumping). See the 'Jumping' type for more details.
--
-- CSJ depends on the ChainSync client to disconnect dynamos that have an empty
-- genesis window after their intersection with the selection. This is necessary
-- because otherwise there are no points to jump to, and CSJ could would get
-- stuck when the dynamo blocks on the forecast horizon. See
-- Note [Candidate comparing beyond the forecast horizon] in
-- "Ouroboros.Consensus.MiniProtocol.ChainSync.Client".
--
-- Interactions with the BlockFetch logic
-- --------------------------------------
--
-- When syncing, the BlockFetch logic might request to change the dynamo with
-- a call to 'rotateDynamo'. This is because the choice of dynamo influences
-- which peer is selected to download blocks. See the note "Interactions with
-- ChainSync Jumping" in "Ouroboros.Network.BlockFetch.Decision.BulkSync".
--
-- Interactions with the Limit on Patience
-- ---------------------------------------
--
-- Jumpers don't leak the Limit on Patience (LoP) bucket until they are promoted
-- to dynamos or objectors. And the leaking is stopped as soon as they are
-- demoted.
--
-- If a jumper refrains from answering to jumps, they will be disconnected with
-- the 'intersectTimeout' (in 'ChainSyncTimeout').
--
-- A jumper answering just before the timeout will not delay the syncing
-- process by a large amount. If they agree with the dynamo, the dynamo will be
-- busy downloading headers and validating blocks while the jumper answers. If
-- the jumper disagrees with the dynamo, CSJ will look for the precise
-- intersection with the dynamo's chain. This could take a few minutes, but it
-- is a path that will end up in one of the dynamo and the jumper being
-- disconnected or disengaged.
--
--
-- Overview of the state transitions
-- ---------------------------------
--
-- See 'ChainSyncJumpingState' for the implementation of the states.
--
-- >                j       ╔════════╗
-- >            ╭────────── ║ Dynamo ║ ◀─────────╮
-- >            │        ╭─ ╚════════╝           │f
-- >            ▼        │         ▲             │
-- >    ┌────────────┐   │         │     k     ┌──────────┐
-- >    │ Disengaged │ ◀─│─────────│────────── │ Objector │
-- >    └────────────┘   │   ╭─────│────────── └──────────┘
-- >                     │   │     │             ▲    ▲ │
-- >                    l│  g│     │e         b  │    │ │
-- >                     │   │     │       ╭─────╯   i│ │c
-- >                 ╭╌╌╌▼╌╌╌▼╌╌╌╌╌╌╌╌╌╌╌╌╌│╌╌╌╌╌╌╌╌╌╌│╌▼╌╌╌╮
-- >                 ┆ ╔═══════╗  a   ┌──────┐  d   ┌─────┐ ┆
-- >                 ┆ ║ Happy ║ ───▶ │ LFI* │ ───▶ │ FI* │ ┆
-- >                 ┆ ╚═══════╝ ◀─╮  └──────┘      └─────┘ ┆
-- >                 ┆ Jumper      ╰─────┴────────────╯h    ┆
-- >                 ╰╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╌╯
--
-- *: LookingForIntersection and FoundIntersection, abbreviated for this
--    drawing only; this abbreviation will not be used elsewhere.
--
-- In the following walk-through, we will point to transitions in the drawing
-- between parentheses, like so: (a) (b+c) (e|f). We will use `+` to express
-- that both transitions happen simultaneously (for different peers) and `|` to
-- express a choice.
--
-- A new peer starts as the dynamo if there is no other peer or as a Happy
-- jumper otherwise. The dynamo periodically requests jumps from happy
-- jumpers who, in the ideal case, accept them and remain happy jumpers.
--
-- In the event that a jumper rejects a jump, it goes from Happy to LFI* (a).
-- From there starts a back-and-forth of intersection search messages until
-- the exact point of disagreement with the dynamo is found.
--
-- Once the exact point of disagreement is found, and if there is no objector
-- yet, the jumper becomes the objector (b). If there is an objector, then we
-- compare the intersection of the objector with the dynamo and the intersection
-- of the jumper with the dynamo. If the jumper's intersection is strictly
-- older, then the jumper replaces the objector, who is marked as FI* (b+c).
-- Otherwise, the jumper is marked as FI* (d).
--
-- If the dynamo disconnects or is disengaged, one peer is elected as the new
-- dynamo (e|f) and all the other peers revert to being happy jumpers (g+h).
--
-- If the objector disconnects or is disengaged, and there are FI* jumpers, then
-- the one with the oldest intersection with the dynamo gets elected (i).
-- Otherwise, we are left with no objector.
--
-- If the dynamo rolls back to a point older than the last jump it requested, it
-- is disengaged (j), a new dynamo is elected (e|f), and all the other peers
-- revert to being happy jumpers (g+h).
--
-- If the objector agrees with the dynamo, it is disengaged (k). If there are
-- FI* jumpers, then one of them gets elected as the new objector (i).
-- Otherwise, we are left with no objector.
--
-- If the dynamo or the objector claim to have no more headers, they are
-- disengaged (j|k), triggering the same chain of effect as described in the two
-- previous points.
--
-- The BlockFetch logic can ask to change the dynamo if it is not serving
-- blocks fast enough. If there are other non-disengaged peers, all peers are
-- demoted to happy jumpers (l+g+h) and a new dynamo is elected (e).
--
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

-- | Hooks for ChainSync jumping.
data Jumping m blk = Jumping
  { -- | Get the next instruction to execute, which can be either to run normal
    -- ChainSync, to jump to a given point, or to restart ChainSync. When the
    -- peer is a jumper and there is no jump request, 'jgNextInstruction' blocks
    -- until a jump request is made.
    forall (m :: * -> *) blk. Jumping m blk -> m (Instruction blk)
jgNextInstruction   :: !(m (Instruction blk)),

    -- | To be called whenever the peer claims to have no more headers.
    forall (m :: * -> *) blk. Jumping m blk -> m ()
jgOnAwaitReply      :: !(m ()),

    -- | To be called whenever a header is received from the peer
    -- before it is validated.
    forall (m :: * -> *) blk.
Jumping m blk -> Point (Header blk) -> m ()
jgOnRollForward     :: !(Point (Header blk) -> m ()),

    -- | To be called whenever a peer rolls back.
    forall (m :: * -> *) blk.
Jumping m blk -> WithOrigin SlotNo -> m ()
jgOnRollBackward    :: !(WithOrigin SlotNo -> m ()),

    -- | Process the result of a jump, either accepted or rejected.
    --
    -- The jump result is used to decide on the next jumps or whether to elect
    -- an objector.
    forall (m :: * -> *) blk. Jumping m blk -> JumpResult blk -> m ()
jgProcessJumpResult :: !(JumpResult blk -> m ()),

    -- | To be called to update the last known jump possible to the tip of
    -- the peers candidate fragment. The ChainSync clients for all peers should
    -- call this function in case they are or they become dynamos.
    --
    -- JumpInfo is meant to be a snapshot of the @KnownIntersectionState@ of
    -- the ChainSync client. See 'JumpInfo' for more details.
    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)

-- | No-op implementation of CSJ
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 ()
    }

-- | Create the callbacks for a given peer.
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))

-- | A context for ChainSync jumping
--
-- Invariants:
--
-- - If 'handlesCol' is not empty, then there is exactly one dynamo in it.
-- - There is at most one objector in 'handlesCol'.
-- - If there exist 'FoundIntersection' jumpers in 'handlesCol', then there
--   is an objector and the intersection of the objector with the dynamo is
--   at least as old as the oldest intersection of the `FoundIntersection` jumpers
--   with the dynamo.
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)
  }

-- | A non-specific, generic context for ChainSync jumping.
type Context = ContextWith () ()

-- | A peer-specific context for ChainSync jumping. This is a 'ContextWith'
-- pointing on the handler of the peer in question.
--
-- Invariant: The binding from 'peer' to 'handle' is present in 'handlesCol'.
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) ->
  -- ^ The size of jumps, in number of slots.
  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

-- | Get a generic context from a peer context by stripping away the
-- peer-specific fields.
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 = ()}

-- | Instruction from the jumping governor, either to run normal ChainSync, or
-- to jump to follow a dynamo with the given fragment, or to restart ChainSync.
data Instruction blk
  = RunNormally
    -- | The restart instruction restarts the ChainSync protocol. This is
    -- necessary when disengaging a peer of which we know no point that we
    -- could set the intersection of the ChainSync server to.
  | Restart
  | -- | Jump to the tip of the given fragment.
    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)
  | -- | Used to set the intersection of the ChainSync servers of starting
    -- objectors and dynamos. Otherwise, the ChainSync server wouldn't know
    -- which headers to start serving.
    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)

-- | The result of a jump request, either accepted or rejected.
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)

-- | Compute the next instruction for the given peer. In the majority of cases,
-- this consists in reading the peer's handle, having the dynamo and objector
-- run normally and the jumpers wait for the next jump. As such, this function
-- mostly only reads from and writes to the handle of the peer. For the dynamo, every once in a
-- while, we need to indicate to the jumpers that they need to jump, and this
-- requires writing to a TVar for every jumper.
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

-- | This function is called when we receive a 'MsgRollForward' message before
-- validating it.
--
-- We request jumpers to jump here if the next header received by the dynamo is
-- at least jump size slots after the last jump. Note that, since this function
-- runs before validating the next header, it will not be part of the fragment
-- considered for the jump.
--
-- We also check that the Objector disagrees with the header sent at its
-- rejected jump. If it agrees to it, we disengage it.
--
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

-- | This function is called when we receive a 'MsgRollBackward' message.
--
-- Here we check if the peer is trying to roll back to a point before the last
-- jump. If so, we disengage the peer. This prevents adversaries from sending
-- as objectors the same chain as the dynamo.
--
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

-- | This function is called when we receive a 'MsgAwaitReply' message.
--
-- If this is the dynamo, we need to elect a new dynamo as no more headers
-- are available.
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{} ->
      -- A jumper might be receiving a 'MsgAwaitReply' message if it was
      -- previously an objector and a new dynamo was elected.
      () -> 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

-- | Process the result of a jump. In the happy case, this only consists in
-- updating the peer's handle to take the new candidate fragment and the new
-- last jump point into account. When disagreeing with the dynamo, though, we
-- enter a phase of several jumps to pinpoint exactly where the disagreement
-- occurs. Once this phase is finished, we trigger the election of a new
-- objector, which might update many TVars.
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)

        -- Not interesting in the dynamo state
        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
          -- If the objector rejects a good point, it is a sign of a rollback
          -- to earlier than the last jump.
          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)

        -- Not interesting in the objector state
        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
            -- The jump was accepted; we set the jumper's candidate fragment to
            -- the dynamo's candidate fragment up to the accepted point.
            --
            -- The candidate fragments of jumpers don't grow otherwise, as only the
            -- objector and the dynamo request further headers.
            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 ->
                -- @AF.headPoint fragment@ is in @badFragment@, as the jumper
                -- looking for an intersection is the only client asking for its
                -- jumps.
                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{} ->
                -- Only happy jumpers are asked to jump by the dynamo, and only
                -- jumpers looking for an intersection are asked to jump by
                -- themselves.
                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) ->
            -- The tip of @goodFragment@ is in @jTheirFragment jumpInfo@ or is
            -- an ancestor of it. If the jump was requested by the dynamo, this
            -- holds because the dynamo is not allowed to rollback before the
            -- jumps that it requests.
            --
            -- If the jump was requested by the jumper, this holds because the
            -- jumper is looking for an intersection, and such jumper only asks
            -- for jumps that meet this condition.
            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."

          -- These aren't interesting in the case of jumpers.
          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
    -- Avoid redundant constraint "HasHeader blk" reported by some ghc's
    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
          -- use the jump info of the rejected jump if the good jump info is
          -- not available (i.e. there were no accepted jumps)
          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

    -- | Given a good point (where we know we agree with the dynamo) and a bad
    -- fragment (where we know the tip disagrees with the dynamo), either decide
    -- that we know the intersection for sure (if the bad point is the successor
    -- of the good point) or program a jump somewhere in the middle to refine
    -- those points.
    --
    -- PRECONDITION: The good point is in the candidate fragment of
    -- @badJumpInfo@ or it is an ancestor of it.
    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
          -- If the good point is not in the bad fragment, the anchor of the bad
          -- fragment should be a good point too.
          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
        -- If the fragment only contains the bad tip, we know the
        -- intersection is the good point.
        -- Clear any subsequent jumps requested by the dynamo.
        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
          -- There is no objector yet. Promote the jumper to objector.
          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
              -- The objector's intersection is still old enough. Keep it.
              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
              -- Found an earlier intersection. Demote the old objector and
              -- promote the jumper to objector.
              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

-- | Find the dynamo in a TVar containing a map of handles. Returns then handle
-- of the dynamo, or 'Nothing' if there is none.
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 a peer, meaning that it will no longer be asked to jump or
-- act as dynamo or objector.
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

-- | Like 'disengage', but additionally restart ChainSync
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


-- | Convenience function that, given an intersection point and a jumper state,
-- make a fresh 'Jumper' constructor.
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

-- | Register a new ChainSync client to a context, returning a 'PeerContext' for
-- that peer. If there is no dynamo, the peer starts as dynamo; otherwise, it
-- starts as a jumper.
--
-- @Note [Updating the CSJ State when the GSM State Changes]@:
--
-- The 'GsmState' argument to this function is the only way that the state of
-- the GSM influences CSJ. In particular, when the GSM state changes, the CSJ
-- state does not need any updates whatsoever. That is remarkable enough to
-- deserve some explanation.
--
-- - The 'GsmState' argument to this function merely causes a new client to be
--   immediately disengaged if the GSM is currently in 'GSM.CaughtUp'.
--   Otherwise, CSJ will initialize that peer as a Jumper instead of running
--   full ChainSync (unless they happen to be immediately promoted to Dynamo,
--   eg they're the first upstream peer).
--
-- - The transition into 'GSM.CaughtUp' does not raise any design questions.
--   The GSM only makes that transition when all peers are idle, and an idle
--   peer will have already disengaged from CSJ. So CSJ doesn't need to react
--   to this transition.
--
-- - The GSM only transitions out of 'GSM.CaughtUp' if the tip of its selection
--   is much older than expected (eg 20 minutes). There are many possible
--   explanations for why that could have happened, so it's not obvious what is
--   the best reaction to that transition. This is the interesting case.
--
-- The relevant high-level assumption is that in the moment the GSM exits the
-- 'GSM.CaughtUp' state, either (i) the node has no proper upstream peers or
-- (ii) the node's selection is out-of-date but not by a huge amount.
--
-- - If the node has no peers, then the CSJ state doesn't need any updates: all
--   of its state is peer-specific. This is anticipated as the main reason the
--   CSJ will leave 'GSM.CaughtUp': eg when the node process was asleep because
--   the user closed the laptop lid overnight.
--
-- - If the node still has peers, then note that they are already disengaged
--   from CSJ, since the GSM was in 'GSM.CaughtUp'. The only reason to
--   re-engage them would be to prevent unnecessary load on them. The key
--   design decision here is that the potential load the node's current peers
--   might be able to avoid if they re-engage CSJ from is not worth the extra
--   complexity in CSJ. It's only ~20min worth of ChainSync headers. And if the
--   node hadn't been, eg, asleep last ~20min, those peers would have all sent
--   those headers anyway---the only difference is that the load arrives in a
--   burst.
--
-- One key remark: the transition out of 'GSM.CaughtUp' does (elsewhere)
-- re-enable the LoP, the LoE, and the GDD, and they apply to all peers
-- regardless of whether those peers are disengaged from CSJ. So security is
-- not directly relevant to this question---recall that CSJ is merely an
-- optimization to avoid excess load on honest upstream peers.
registerClient ::
  ( LedgerSupportsProtocol blk,
    IOLike m
  ) =>
  GsmState ->
  -- ^ the GSM state as of when the node connected to the upstream peer
  Context m peer blk ->
  peer ->
  StrictTVar m (ChainSyncState blk) ->
  -- | A function to make a client handle from a jumping state.
  (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)
      -- This branch disables CSJ while the GSM is in the CaughtUp state.
    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)

-- | A helper for 'registerClient'
--
-- /NOT EXPORTED/
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)

-- | Unregister a client from a 'PeerContext'; this might trigger the election
-- of a new dynamo or objector if the peer was one of these two.
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'

-- | Elects a new dynamo by demoting the given dynamo (and the objector if there
-- is one) to a jumper, moving the peer to the end of the queue of chain sync
-- handles and electing a new dynamo.
--
-- It does nothing if there is no other engaged peer to elect or if the given
-- peer is not the dynamo.
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 ->
        -- Do not re-elect a dynamo if the peer has been disconnected.
        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 ->
                -- There are no engaged peers. This case cannot happen, as the
                -- dynamo is always engaged.
                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 ->
                  -- The old dynamo is the only engaged peer left.
                  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
_ ->
            -- Do not re-elect a dynamo if the peer is not the dynamo.
            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

-- | Choose an unspecified new non-idling dynamo and demote all other peers to
-- jumpers.
--
-- Prefer an 'Objector' that has already 'Started'. Such a peer can trivially
-- transition to be the Dynamo, without any disruption to their ChainSync
-- state. Moreover, if that Objector is honest, then their being the new Dynamo
-- prevents the possibility of their candidate chain being lost and having to
-- eventually be re-downloaded, which CSJ ought to avoid.
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
    -- prefer a 'Started' 'Objector', if any exists
    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))

-- | Promote the given peer to dynamo and demote all other peers to jumpers.
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
    -- An 'Objector' that already 'Started' need not be disrupted.
    --
    -- Remark. Intuitively, a 'Starting' 'Objector' also need not be disrupted,
    -- but disrupting it wouldn't waste any @MsgRollForward@s. More concretely,
    -- it's not obvious how to build a 'DynamoStarting' from a 'Starting'.
    Objector ObjectorInitState
Started JumpInfo blk
oGoodJI Point (Header blk)
_oBad -> do
      -- This intersection point is necessarily behind the replaced Dynamos's
      -- latest jump instruction, but its relative age is bounded.
      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
    -- Otherwise, the peer being promoted could be a Jumper or an Objector
    -- Starting, but never Dynamo nor Disengaged.
    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)
      -- If there is no jump info, the dynamo must be just starting and
      -- there is no need to set the intersection of the ChainSync server.
      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'

  -- Demote all other peers to jumpers
  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)

-- | Find a non-disengaged peer in the given sequence
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

-- | Find the objector in a context, if there is one.
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

-- | Look into all dissenting jumper and promote the one with the oldest
-- intersection with the dynamo as the new objector.
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

-- | Events due to the centralized Devoted BlockFetch logic
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)

-- | Events arising from a specific ChainSync client
data TraceEventCsj peer blk
  = BecomingObjector (Maybe peer)   -- ^ previous objector
  | BlockedOnJump
  | InitializedAsDynamo
  | NoLongerDynamo (Maybe peer) TraceCsjReason   -- ^ new dynamo if known
  | NoLongerObjector (Maybe peer) TraceCsjReason  -- ^ new objector if known
  | SentJumpInstruction (Point blk)   -- ^ jump target
  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