{-# 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.
--
-- 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 │
-- >    └────────────┘       ╭─────│────────── └──────────┘
-- >                         │     │             ▲    ▲ │
-- >                        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.
--
-- 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.
--
-- 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 intersections of the objector and the jumper. If the jumper's
-- intersection is strictly older, then the jumper replaces the objector (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 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).
--
-- If the dynamo rolls back to a point older than the last jump it requested, it
-- is disengaged (j) and a new dynamo is elected (e|f).
--
-- 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).
--
-- If dynamo or objector claim to have no more headers, they are disengaged
-- (j|k).
--
module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping (
    Context
  , ContextWith (..)
  , Instruction (..)
  , JumpInstruction (..)
  , JumpResult (..)
  , Jumping (..)
  , makeContext
  , mkJumping
  , noJumping
  , registerClient
  , unregisterClient
  ) where

import           Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
import           Control.Monad (forM, forM_, when)
import           Data.List (sortOn)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (catMaybes, fromMaybe)
import           Data.Maybe.Strict (StrictMaybe (..))
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 (..),
                     ChainSyncJumpingJumperState (..),
                     ChainSyncJumpingState (..), ChainSyncState (..),
                     DisengagedInitState (..), DynamoInitState (..),
                     JumpInfo (..), JumperInitState (..),
                     ObjectorInitState (..))
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 (Instruction blk) -> m (Instruction blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Instruction blk) -> m (Instruction blk))
-> STM m (Instruction blk) -> m (Instruction blk)
forall a b. (a -> b) -> a -> b
$ PeerContext m peer blk -> STM m (Instruction blk)
forall (m :: * -> *) peer blk.
MonadSTM m =>
PeerContext m peer blk -> STM m (Instruction blk)
nextInstruction PeerContext m peer blk
peerContext
  , jgOnAwaitReply :: m ()
jgOnAwaitReply = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ PeerContext m peer blk -> STM m ()
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> STM m ()
onAwaitReply PeerContext m peer blk
peerContext
  , jgOnRollForward :: Point (Header blk) -> m ()
jgOnRollForward = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> (Point (Header blk) -> STM m ()) -> Point (Header blk) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerContext m peer blk -> Point (Header blk) -> STM m ()
forall (m :: * -> *) peer blk.
(MonadSTM m, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> Point (Header blk) -> STM m ()
onRollForward PeerContext m peer blk
peerContext
  , jgOnRollBackward :: WithOrigin SlotNo -> m ()
jgOnRollBackward = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> (WithOrigin SlotNo -> STM m ()) -> WithOrigin SlotNo -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerContext m peer blk -> WithOrigin SlotNo -> STM m ()
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> WithOrigin SlotNo -> STM m ()
onRollBackward PeerContext m peer blk
peerContext
  , jgProcessJumpResult :: JumpResult blk -> m ()
jgProcessJumpResult = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> (JumpResult blk -> STM m ()) -> JumpResult blk -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerContext m peer blk -> JumpResult blk -> STM m ()
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> JumpResult blk -> STM m ()
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
  }

-- | A context for ChainSync jumping
--
-- Invariants:
--
-- - If 'handlesVar' is not empty, then there is exactly one dynamo in it.
-- - There is at most one objector in 'handlesVar'.
-- - If there exist 'FoundIntersection' jumpers in 'handlesVar', 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
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
handlesVar :: !(StrictTVar m (Map peer (ChainSyncClientHandle m blk))),
    forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk -> SlotNo
jumpSize   :: !SlotNo
  }

-- | 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 'handlesVar'.
type PeerContext m peer blk = ContextWith peer (ChainSyncClientHandle m blk) m peer blk

makeContext ::
  MonadSTM m =>
  StrictTVar m (Map peer (ChainSyncClientHandle m blk)) ->
  SlotNo ->
  -- ^ The size of jumps, in number of slots.
  STM m (Context m peer blk)
makeContext :: forall (m :: * -> *) peer blk.
MonadSTM m =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> SlotNo -> STM m (Context m peer blk)
makeContext StrictTVar m (Map peer (ChainSyncClientHandle m blk))
h SlotNo
jumpSize = 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
$ ()
-> ()
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> SlotNo
-> Context m peer blk
forall peerField handleField (m :: * -> *) peer blk.
peerField
-> handleField
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> SlotNo
-> ContextWith peerField handleField m peer blk
Context () () StrictTVar m (Map peer (ChainSyncClientHandle m blk))
h SlotNo
jumpSize

-- | 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 (HasHeader (Header blk), Eq (Header blk)) => Eq (Instruction blk)
deriving instance (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 (HasHeader (Header blk), Eq (Header blk)) => Eq (JumpInstruction blk)
instance (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 (Header blk) -> ShowS
forall a. Show a => a -> ShowS
shows (AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (Header blk) -> Point (Header blk))
-> AnchoredFragment (Header blk) -> Point (Header blk)
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (Header blk)
forall blk. JumpInfo blk -> AnchoredFragment (Header 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 (Header blk) -> ShowS
forall a. Show a => a -> ShowS
shows (AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (Header blk) -> Point (Header blk))
-> AnchoredFragment (Header blk) -> Point (Header blk)
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (Header blk)
forall blk. JumpInfo blk -> AnchoredFragment (Header 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 (HasHeader (Header blk), Eq (Header blk)) => Eq (JumpResult blk)
deriving instance (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 ) =>
  PeerContext m peer blk ->
  STM m (Instruction blk)
nextInstruction :: forall (m :: * -> *) peer blk.
MonadSTM m =>
PeerContext m peer blk -> STM m (Instruction blk)
nextInstruction 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 (Instruction blk))
-> STM m (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 (Instruction blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (Instruction blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (Instruction blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instruction blk -> STM m (Instruction blk))
-> Instruction blk -> STM m (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 (Instruction blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (Instruction blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instruction blk -> STM m (Instruction blk))
-> Instruction blk -> STM m (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 (Instruction blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (Instruction blk))
-> STM m (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 -> STM m (Instruction blk)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
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 (Instruction blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instruction blk -> STM m (Instruction blk))
-> Instruction blk -> STM m (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

-- | 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 ()
onRollForward :: forall (m :: * -> *) peer blk.
(MonadSTM m, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> Point (Header blk) -> STM m ()
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 ()) -> 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
    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)
          Context m peer blk -> STM m ()
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk -> STM m ()
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 -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Disengaged{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Jumper{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    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
          Maybe (JumpInfo blk)
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))
          Maybe (JumpInfo blk) -> STM m ()
setJumps Maybe (JumpInfo blk)
mJumpInfo
      | Bool
otherwise -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    setJumps :: Maybe (JumpInfo blk) -> STM m ()
setJumps Maybe (JumpInfo blk)
Nothing = String -> STM m ()
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
$ Point (Header blk) -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point (Header blk) -> WithOrigin SlotNo)
-> Point (Header blk) -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (Header blk) -> Point (Header blk))
-> AnchoredFragment (Header blk) -> Point (Header blk)
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (Header blk)
forall blk. JumpInfo blk -> AnchoredFragment (Header blk)
jTheirFragment JumpInfo blk
jumpInfo
        Map peer (ChainSyncClientHandle m blk)
handles <- StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> STM m (Map peer (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (PeerContext m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
handlesVar PeerContext m peer blk
context)
        [ChainSyncClientHandle m blk]
-> (ChainSyncClientHandle m blk -> STM m ()) -> STM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map peer (ChainSyncClientHandle m blk)
-> [ChainSyncClientHandle m blk]
forall k a. Map k a -> [a]
Map.elems Map peer (ChainSyncClientHandle m blk)
handles) ((ChainSyncClientHandle m blk -> STM m ()) -> STM m ())
-> (ChainSyncClientHandle m blk -> STM m ()) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \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 ()

-- | 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 ()
onRollBackward :: forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> WithOrigin SlotNo -> STM m ()
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 ()) -> 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
    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)
          Context m peer blk -> STM m ()
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk -> STM m ()
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 -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Disengaged{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Jumper{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    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)
          Context m peer blk -> STM m ()
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
Context m peer blk -> STM m ()
electNewDynamo (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 -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | 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 ()
onAwaitReply :: forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> STM m ()
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 ()) -> 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
    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)
      Context m peer blk -> STM m ()
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
Context m peer blk -> STM m ()
electNewDynamo (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)
      Context m peer blk -> STM m ()
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk -> STM m ()
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.
      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{} ->
      () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | 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 ()
processJumpResult :: forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> JumpResult blk -> STM m ()
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 ()) -> 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
    Dynamo{} ->
      case JumpResult blk
jumpResult of
        AcceptedJump (JumpToGoodPoint JumpInfo blk
jumpInfo) ->
          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)
          Context m peer blk -> STM m ()
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
Context m peer blk -> STM m ()
electNewDynamo (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{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        RejectedJump JumpTo{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    Disengaged{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Objector{} ->
      case JumpResult blk
jumpResult of
        AcceptedJump (JumpToGoodPoint JumpInfo blk
jumpInfo) ->
          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)
          Context m peer blk -> STM m ()
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk -> STM m ()
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{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        RejectedJump JumpTo{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    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 ()
lookForIntersection StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar JumpInfo blk
goodJumpInfo JumpInfo blk
badJumpInfo
              Happy JumperInitState
StartedJumper 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) -> 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
              Happy JumperInitState
FreshJumper Maybe (JumpInfo blk)
_mGoodJumpInfo ->
                () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              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 ()
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 ()
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 ()
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)
_ ->
                () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              FoundIntersection{} ->
                String -> STM m ()
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{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          RejectedJump JumpToGoodPoint{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  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 (Header blk)
fragment = JumpInfo blk -> AnchoredFragment (Header blk)
forall blk. JumpInfo blk -> AnchoredFragment (Header 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 (Header blk)
badFragment = JumpInfo blk -> AnchoredFragment (Header blk)
forall blk. JumpInfo blk -> AnchoredFragment (Header 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 (Header blk)
badFragmentStart = Int
-> AnchoredFragment (Header blk) -> AnchoredFragment (Header blk)
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.takeOldest Int
0 AnchoredFragment (Header 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 ()
lookForIntersection StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar JumpInfo blk
goodJumpInfo JumpInfo blk
badJumpInfo = do
      let badFragment :: AnchoredFragment (Header blk)
badFragment = JumpInfo blk -> AnchoredFragment (Header blk)
forall blk. JumpInfo blk -> AnchoredFragment (Header 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 (Header blk)
searchFragment =
              AnchoredFragment (Header blk)
-> ((AnchoredFragment (Header blk), AnchoredFragment (Header blk))
    -> AnchoredFragment (Header blk))
-> Maybe
     (AnchoredFragment (Header blk), AnchoredFragment (Header blk))
-> AnchoredFragment (Header blk)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AnchoredFragment (Header blk)
badFragment (AnchoredFragment (Header blk), AnchoredFragment (Header blk))
-> AnchoredFragment (Header blk)
forall a b. (a, b) -> b
snd (Maybe
   (AnchoredFragment (Header blk), AnchoredFragment (Header blk))
 -> AnchoredFragment (Header blk))
-> Maybe
     (AnchoredFragment (Header blk), AnchoredFragment (Header blk))
-> AnchoredFragment (Header blk)
forall a b. (a -> b) -> a -> b
$
                AnchoredFragment (Header blk)
-> Point (Header blk)
-> Maybe
     (AnchoredFragment (Header blk), AnchoredFragment (Header blk))
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
AF.splitAfterPoint AnchoredFragment (Header blk)
badFragment (AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (Header blk) -> Point (Header blk))
-> AnchoredFragment (Header blk) -> Point (Header blk)
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (Header blk)
forall blk. JumpInfo blk -> AnchoredFragment (Header blk)
jTheirFragment JumpInfo blk
goodJumpInfo)
      let len :: Int
len = AnchoredFragment (Header blk) -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment (Header 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 ()
maybeElectNewObjector StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar JumpInfo blk
goodJumpInfo (AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
badFragment)
      else do
        let middlePoint :: Int
middlePoint = Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
            theirFragment :: AnchoredFragment (Header blk)
theirFragment = Int
-> AnchoredFragment (Header blk) -> AnchoredFragment (Header blk)
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropNewest Int
middlePoint AnchoredFragment (Header 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)

    maybeElectNewObjector :: StrictTVar m (Maybe (JumpInfo blk))
-> JumpInfo blk -> Point (Header blk) -> STM m ()
maybeElectNewObjector StrictTVar m (Maybe (JumpInfo blk))
nextJumpVar JumpInfo blk
goodJumpInfo Point (Header blk)
badPoint = do
      Context m peer blk
-> STM
     m
     (Maybe
        (ObjectorInitState, JumpInfo blk, Point (Header blk),
         ChainSyncClientHandle m blk))
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk
-> STM
     m
     (Maybe
        (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
     (ObjectorInitState, JumpInfo blk, Point (Header blk),
      ChainSyncClientHandle m blk))
-> (Maybe
      (ObjectorInitState, JumpInfo blk, Point (Header blk),
       ChainSyncClientHandle 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
        Maybe
  (ObjectorInitState, JumpInfo blk, Point (Header blk),
   ChainSyncClientHandle m blk)
Nothing ->
          -- 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)
        Just (ObjectorInitState
oInitState, JumpInfo blk
oGoodJump, Point (Header blk)
oPoint, ChainSyncClientHandle m blk
oHandle)
          | Point (Header blk) -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point (Header blk)
oPoint 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 ->
              -- 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)
          | 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)
oPoint) 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)

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) =>
  StrictTVar m (Map peer (ChainSyncClientHandle m blk)) ->
  STM m (Maybe (ChainSyncClientHandle m blk))
getDynamo :: forall (m :: * -> *) peer blk.
MonadSTM m =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> STM m (Maybe (ChainSyncClientHandle m blk))
getDynamo StrictTVar m (Map peer (ChainSyncClientHandle m blk))
handlesVar = do
  [ChainSyncClientHandle m blk]
handles <- Map peer (ChainSyncClientHandle m blk)
-> [ChainSyncClientHandle m blk]
forall k a. Map k a -> [a]
Map.elems (Map peer (ChainSyncClientHandle m blk)
 -> [ChainSyncClientHandle m blk])
-> STM m (Map peer (ChainSyncClientHandle m blk))
-> STM m [ChainSyncClientHandle m blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> STM m (Map peer (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map peer (ChainSyncClientHandle m blk))
handlesVar
  (ChainSyncClientHandle m blk -> STM m Bool)
-> [ChainSyncClientHandle m blk]
-> STM m (Maybe (ChainSyncClientHandle m blk))
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM (\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)) [ChainSyncClientHandle m blk]
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
  StrictTVar m (Maybe (JumpInfo blk))
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
  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
$ 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
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.
registerClient ::
  ( Ord peer,
    LedgerSupportsProtocol blk,
    IOLike m
  ) =>
  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)
registerClient :: forall peer blk (m :: * -> *).
(Ord peer, LedgerSupportsProtocol blk, IOLike m) =>
Context m peer blk
-> peer
-> StrictTVar m (ChainSyncState blk)
-> (StrictTVar m (ChainSyncJumpingState m blk)
    -> ChainSyncClientHandle m blk)
-> STM m (PeerContext m peer blk)
registerClient Context m peer blk
context peer
peer StrictTVar m (ChainSyncState blk)
csState StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncClientHandle m blk
mkHandle = do
  ChainSyncJumpingState m blk
csjState <- StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> STM m (Maybe (ChainSyncClientHandle m blk))
forall (m :: * -> *) peer blk.
MonadSTM m =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> STM m (Maybe (ChainSyncClientHandle m blk))
getDynamo (Context m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
handlesVar Context m peer blk
context) STM m (Maybe (ChainSyncClientHandle m blk))
-> (Maybe (ChainSyncClientHandle m blk)
    -> STM m (ChainSyncJumpingState m blk))
-> STM m (ChainSyncJumpingState 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
    Maybe (ChainSyncClientHandle m blk)
Nothing -> do
      AnchoredFragment (Header blk)
fragment <- ChainSyncState blk -> AnchoredFragment (Header blk)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
csCandidate (ChainSyncState blk -> AnchoredFragment (Header blk))
-> STM m (ChainSyncState blk)
-> STM m (AnchoredFragment (Header 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
      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 -> ChainSyncJumpingState m blk)
-> WithOrigin SlotNo -> ChainSyncJumpingState m blk
forall a b. (a -> b) -> a -> b
$ Point (Header blk) -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point (Header blk) -> WithOrigin SlotNo)
-> Point (Header blk) -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment (Header blk)
fragment
    Just ChainSyncClientHandle m blk
handle -> do
      Maybe (JumpInfo blk)
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)
      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)
mJustInfo (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)
  StrictTVar m (ChainSyncJumpingState m blk)
cschJumping <- ChainSyncJumpingState m blk
-> STM m (StrictTVar m (ChainSyncJumpingState m blk))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> STM m (StrictTVar m a)
newTVar ChainSyncJumpingState m blk
csjState
  let handle :: ChainSyncClientHandle m blk
handle = StrictTVar m (ChainSyncJumpingState m blk)
-> ChainSyncClientHandle m blk
mkHandle StrictTVar m (ChainSyncJumpingState m blk)
cschJumping
  StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> (Map peer (ChainSyncClientHandle m blk)
    -> Map peer (ChainSyncClientHandle m blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (Context m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
handlesVar Context m peer blk
context) ((Map peer (ChainSyncClientHandle m blk)
  -> Map peer (ChainSyncClientHandle m blk))
 -> STM m ())
-> (Map peer (ChainSyncClientHandle m blk)
    -> Map peer (ChainSyncClientHandle m blk))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ peer
-> ChainSyncClientHandle m blk
-> Map peer (ChainSyncClientHandle m blk)
-> Map peer (ChainSyncClientHandle m blk)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert peer
peer ChainSyncClientHandle m blk
handle
  PeerContext m peer blk -> STM m (PeerContext m peer blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PeerContext m peer blk -> STM m (PeerContext m peer blk))
-> PeerContext m peer blk -> STM m (PeerContext m peer blk)
forall a b. (a -> b) -> a -> b
$ Context m peer blk
context {peer, handle}

-- | 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 ()
unregisterClient :: forall (m :: * -> *) peer blk.
(MonadSTM m, Ord peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> STM m ()
unregisterClient PeerContext m peer blk
context = do
  StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> (Map peer (ChainSyncClientHandle m blk)
    -> Map peer (ChainSyncClientHandle m blk))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar (PeerContext m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
handlesVar PeerContext m peer blk
context) ((Map peer (ChainSyncClientHandle m blk)
  -> Map peer (ChainSyncClientHandle m blk))
 -> STM m ())
-> (Map peer (ChainSyncClientHandle m blk)
    -> Map peer (ChainSyncClientHandle m blk))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ peer
-> Map peer (ChainSyncClientHandle m blk)
-> Map peer (ChainSyncClientHandle m blk)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (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 ()) -> 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 ()
    Jumper{} -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Objector{} -> Context m peer blk -> STM m ()
forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk -> STM m ()
electNewObjector Context m peer blk
context'
    Dynamo{} -> Context m peer blk -> STM m ()
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
Context m peer blk -> STM m ()
electNewDynamo Context m peer blk
context'

-- | Choose an unspecified new non-idling dynamo and demote all other peers to
-- jumpers.
electNewDynamo ::
  ( MonadSTM m,
    Eq peer,
    LedgerSupportsProtocol blk
  ) =>
  Context m peer blk ->
  STM m ()
electNewDynamo :: forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
Context m peer blk -> STM m ()
electNewDynamo Context m peer blk
context = do
  [(peer, ChainSyncClientHandle m blk)]
peerStates <- Map peer (ChainSyncClientHandle m blk)
-> [(peer, ChainSyncClientHandle m blk)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map peer (ChainSyncClientHandle m blk)
 -> [(peer, ChainSyncClientHandle m blk)])
-> STM m (Map peer (ChainSyncClientHandle m blk))
-> STM m [(peer, ChainSyncClientHandle m blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> STM m (Map peer (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (Context m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
handlesVar Context m peer blk
context)
  Maybe (peer, ChainSyncClientHandle m blk)
mDynamo <- [(peer, ChainSyncClientHandle m blk)]
-> STM m (Maybe (peer, ChainSyncClientHandle m blk))
forall {a} {blk}.
[(a, ChainSyncClientHandle m blk)]
-> STM m (Maybe (a, ChainSyncClientHandle m blk))
findNonDisengaged [(peer, ChainSyncClientHandle m blk)]
peerStates
  case Maybe (peer, ChainSyncClientHandle m blk)
mDynamo of
    Maybe (peer, ChainSyncClientHandle m blk)
Nothing -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (peer
dynId, ChainSyncClientHandle m blk
dynamo) -> do
      AnchoredFragment (Header blk)
fragment <- ChainSyncState blk -> AnchoredFragment (Header blk)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
csCandidate (ChainSyncState blk -> AnchoredFragment (Header blk))
-> STM m (ChainSyncState blk)
-> STM m (AnchoredFragment (Header 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)
      Maybe (JumpInfo blk)
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)
      -- 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
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
      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
dynamo) (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
dynamoInitState (WithOrigin SlotNo -> ChainSyncJumpingState m blk)
-> WithOrigin SlotNo -> ChainSyncJumpingState m blk
forall a b. (a -> b) -> a -> b
$ Point (Header blk) -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point (Header blk) -> WithOrigin SlotNo)
-> Point (Header blk) -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
fragment
      -- Demote all other peers to jumpers
      [(peer, ChainSyncClientHandle m blk)]
-> ((peer, ChainSyncClientHandle m blk) -> STM m ()) -> STM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(peer, ChainSyncClientHandle m blk)]
peerStates (((peer, ChainSyncClientHandle m blk) -> STM m ()) -> STM m ())
-> ((peer, ChainSyncClientHandle m blk) -> STM m ()) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \(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
          ChainSyncJumpingState m blk
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)
          Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (ChainSyncJumpingState m blk -> Bool
forall {m :: * -> *} {blk}. ChainSyncJumpingState m blk -> Bool
isDisengaged ChainSyncJumpingState m blk
jumpingState)) (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$
            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)
mJumpInfo (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
st)
  where
    findNonDisengaged :: [(a, ChainSyncClientHandle m blk)]
-> STM m (Maybe (a, ChainSyncClientHandle m blk))
findNonDisengaged =
      ((a, ChainSyncClientHandle m blk) -> STM m Bool)
-> [(a, ChainSyncClientHandle m blk)]
-> STM m (Maybe (a, ChainSyncClientHandle m blk))
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM (((a, ChainSyncClientHandle m blk) -> STM m Bool)
 -> [(a, ChainSyncClientHandle m blk)]
 -> STM m (Maybe (a, ChainSyncClientHandle m blk)))
-> ((a, ChainSyncClientHandle m blk) -> STM m Bool)
-> [(a, ChainSyncClientHandle m blk)]
-> STM m (Maybe (a, ChainSyncClientHandle m blk))
forall a b. (a -> b) -> a -> b
$ \(a
_, 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 Disengaged{} = Bool
True
    isDisengaged ChainSyncJumpingState m blk
_            = Bool
False

findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM :: forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM a -> m Bool
_ [] = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
findM a -> m Bool
p (a
x : [a]
xs) = a -> m Bool
p a
x m Bool -> (Bool -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
True -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
  Bool
False -> (a -> m Bool) -> [a] -> m (Maybe a)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM a -> m Bool
p [a]
xs

-- | Find the objector in a context, if there is one.
findObjector ::
  (MonadSTM m) =>
  Context m peer blk ->
  STM m (Maybe (ObjectorInitState, JumpInfo blk, Point (Header blk), ChainSyncClientHandle m blk))
findObjector :: forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk
-> STM
     m
     (Maybe
        (ObjectorInitState, JumpInfo blk, Point (Header blk),
         ChainSyncClientHandle m blk))
findObjector Context m peer blk
context = do
  StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> STM m (Map peer (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (Context m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
handlesVar Context m peer blk
context) STM m (Map peer (ChainSyncClientHandle m blk))
-> (Map peer (ChainSyncClientHandle m blk)
    -> STM
         m
         (Maybe
            (ObjectorInitState, JumpInfo blk, Point (Header blk),
             ChainSyncClientHandle m blk)))
-> STM
     m
     (Maybe
        (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
>>= [(peer, ChainSyncClientHandle m blk)]
-> STM
     m
     (Maybe
        (ObjectorInitState, JumpInfo blk, Point (Header blk),
         ChainSyncClientHandle m blk))
forall {m :: * -> *} {a} {blk}.
MonadSTM m =>
[(a, ChainSyncClientHandle m blk)]
-> STM
     m
     (Maybe
        (ObjectorInitState, JumpInfo blk, Point (Header blk),
         ChainSyncClientHandle m blk))
go ([(peer, ChainSyncClientHandle m blk)]
 -> STM
      m
      (Maybe
         (ObjectorInitState, JumpInfo blk, Point (Header blk),
          ChainSyncClientHandle m blk)))
-> (Map peer (ChainSyncClientHandle m blk)
    -> [(peer, ChainSyncClientHandle m blk)])
-> Map peer (ChainSyncClientHandle m blk)
-> STM
     m
     (Maybe
        (ObjectorInitState, JumpInfo blk, Point (Header blk),
         ChainSyncClientHandle m blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map peer (ChainSyncClientHandle m blk)
-> [(peer, ChainSyncClientHandle m blk)]
forall k a. Map k a -> [(k, a)]
Map.toList
  where
    go :: [(a, ChainSyncClientHandle m blk)]
-> STM
     m
     (Maybe
        (ObjectorInitState, JumpInfo blk, Point (Header blk),
         ChainSyncClientHandle m blk))
go [] = Maybe
  (ObjectorInitState, JumpInfo blk, Point (Header blk),
   ChainSyncClientHandle m blk)
-> STM
     m
     (Maybe
        (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
  (ObjectorInitState, JumpInfo blk, Point (Header blk),
   ChainSyncClientHandle m blk)
forall a. Maybe a
Nothing
    go ((a
_, ChainSyncClientHandle m blk
handle):[(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
            (ObjectorInitState, JumpInfo blk, Point (Header blk),
             ChainSyncClientHandle m blk)))
-> STM
     m
     (Maybe
        (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
  (ObjectorInitState, JumpInfo blk, Point (Header blk),
   ChainSyncClientHandle m blk)
-> STM
     m
     (Maybe
        (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
   (ObjectorInitState, JumpInfo blk, Point (Header blk),
    ChainSyncClientHandle m blk)
 -> STM
      m
      (Maybe
         (ObjectorInitState, JumpInfo blk, Point (Header blk),
          ChainSyncClientHandle m blk)))
-> Maybe
     (ObjectorInitState, JumpInfo blk, Point (Header blk),
      ChainSyncClientHandle m blk)
-> STM
     m
     (Maybe
        (ObjectorInitState, JumpInfo blk, Point (Header blk),
         ChainSyncClientHandle m blk))
forall a b. (a -> b) -> a -> b
$ (ObjectorInitState, JumpInfo blk, Point (Header blk),
 ChainSyncClientHandle m blk)
-> Maybe
     (ObjectorInitState, JumpInfo blk, Point (Header blk),
      ChainSyncClientHandle m blk)
forall a. a -> Maybe a
Just (ObjectorInitState
initState, JumpInfo blk
goodJump, Point (Header blk)
badPoint, ChainSyncClientHandle m blk
handle)
        ChainSyncJumpingState m blk
_ -> [(a, ChainSyncClientHandle m blk)]
-> STM
     m
     (Maybe
        (ObjectorInitState, JumpInfo blk, Point (Header blk),
         ChainSyncClientHandle m blk))
go [(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 ()
electNewObjector :: forall (m :: * -> *) peer blk.
MonadSTM m =>
Context m peer blk -> STM m ()
electNewObjector Context m peer blk
context = do
  [(peer, ChainSyncClientHandle m blk)]
peerStates <- Map peer (ChainSyncClientHandle m blk)
-> [(peer, ChainSyncClientHandle m blk)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map peer (ChainSyncClientHandle m blk)
 -> [(peer, ChainSyncClientHandle m blk)])
-> STM m (Map peer (ChainSyncClientHandle m blk))
-> STM m [(peer, ChainSyncClientHandle m blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> STM m (Map peer (ChainSyncClientHandle m blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (Context m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
handlesVar Context m peer blk
context)
  [(Point (Header blk),
  (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
dissentingJumpers <- [(peer, ChainSyncClientHandle m blk)]
-> STM
     m
     [(Point (Header blk),
       (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
forall {m :: * -> *} {a} {blk}.
MonadSTM m =>
[(a, ChainSyncClientHandle m blk)]
-> STM
     m
     [(Point (Header blk),
       (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
collectDissentingJumpers [(peer, ChainSyncClientHandle m blk)]
peerStates
  let sortedJumpers :: [(Point (Header blk),
  (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
sortedJumpers = ((Point (Header blk),
  (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
 -> WithOrigin SlotNo)
-> [(Point (Header blk),
     (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
-> [(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)
-> ((Point (Header blk),
     (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
    -> Point (Header blk))
-> (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))]
dissentingJumpers
  case [(Point (Header blk),
  (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
sortedJumpers of
    (Point (Header blk)
badPoint, (ObjectorInitState
initState, JumpInfo blk
goodJumpInfo, ChainSyncClientHandle m blk
handle)):[(Point (Header blk),
  (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
_ ->
      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
    [(Point (Header blk),
  (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
_ ->
      () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    collectDissentingJumpers :: [(a, ChainSyncClientHandle m blk)]
-> STM
     m
     [(Point (Header blk),
       (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
collectDissentingJumpers [(a, ChainSyncClientHandle m blk)]
peerStates =
      ([Maybe
    (Point (Header blk),
     (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
 -> [(Point (Header blk),
      (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))])
-> STM
     m
     [Maybe
        (Point (Header blk),
         (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
-> STM
     m
     [(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
   (Point (Header blk),
    (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
-> [(Point (Header blk),
     (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
forall a. [Maybe a] -> [a]
catMaybes (STM
   m
   [Maybe
      (Point (Header blk),
       (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
 -> STM
      m
      [(Point (Header blk),
        (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))])
-> STM
     m
     [Maybe
        (Point (Header blk),
         (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
-> STM
     m
     [(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
            (Point (Header blk),
             (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))))
-> STM
     m
     [Maybe
        (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
          (Point (Header blk),
           (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))))
 -> STM
      m
      [Maybe
         (Point (Header blk),
          (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))])
-> ((a, ChainSyncClientHandle m blk)
    -> STM
         m
         (Maybe
            (Point (Header blk),
             (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))))
-> STM
     m
     [Maybe
        (Point (Header blk),
         (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))]
forall a b. (a -> b) -> a -> b
$ \(a
_, 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
            (Point (Header blk),
             (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))))
-> STM
     m
     (Maybe
        (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
  (Point (Header blk),
   (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
-> STM
     m
     (Maybe
        (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
   (Point (Header blk),
    (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
 -> STM
      m
      (Maybe
         (Point (Header blk),
          (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))))
-> Maybe
     (Point (Header blk),
      (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
-> STM
     m
     (Maybe
        (Point (Header blk),
         (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk)))
forall a b. (a -> b) -> a -> b
$ (Point (Header blk),
 (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
-> Maybe
     (Point (Header blk),
      (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
forall a. a -> Maybe a
Just (Point (Header blk)
badPoint, (ObjectorInitState
initState, JumpInfo blk
goodJumpInfo, ChainSyncClientHandle m blk
handle))
          ChainSyncJumpingState m blk
_ ->
            Maybe
  (Point (Header blk),
   (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
-> STM
     m
     (Maybe
        (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
  (Point (Header blk),
   (ObjectorInitState, JumpInfo blk, ChainSyncClientHandle m blk))
forall a. Maybe a
Nothing