{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -fno-strictness #-}

-- NOTE: With @-fstrictness@ optimisation (enabled by default for -O1), we get
-- an unexplained thunk in 'KnownIntersectionState' and thus a space leak. See
-- #1356.

-- | The ChainSync client logic
--
-- Its core specification is found in "The Shelley Networking Protocol",
-- currently found at
-- <https://ouroboros-network.cardano.intersectmbo.org/pdfs/network-spec/network-spec.pdf>.
--
-- It would be difficult to maintain or extrend this module without
-- understanding the @typed-protocols@ architecture; eg see
-- <https://github.com/input-output-hk/typed-protocols>.
--
-- This module is intended for qualified import, aliased as either CSC,
-- CSClient, or CsClient.

module Ouroboros.Consensus.MiniProtocol.ChainSync.Client (
    -- * ChainSync client
    bracketChainSyncClient
  , chainSyncClient
    -- * Arguments
  , ChainDbView (..)
  , ConfigEnv (..)
  , DynamicEnv (..)
  , InternalEnv (..)
  , defaultChainDbView
    -- * Results
  , ChainSyncClientException (..)
  , ChainSyncClientResult (..)
    -- * Misc
  , Consensus
  , Our (..)
  , Their (..)
    -- * Genesis configuration
  , CSJConfig (..)
  , CSJEnabledConfig (..)
  , ChainSyncLoPBucketConfig (..)
  , ChainSyncLoPBucketEnabledConfig (..)
    -- * Trace events
  , TraceChainSyncClientEvent (..)
    -- * State shared with other components
  , ChainSyncClientHandle (..)
  , ChainSyncClientHandleCollection (..)
  , ChainSyncState (..)
  , ChainSyncStateView (..)
  , Jumping.noJumping
  , chainSyncStateFor
  , newChainSyncClientHandleCollection
  , noIdling
  , noLoPBucket
  , viewChainSyncState
  ) where

import           Cardano.Ledger.BaseTypes (unNonZero)
import           Control.Monad (join, void)
import           Control.Monad.Class.MonadTimer (MonadTimer)
import           Control.Monad.Except (runExcept, throwError)
import           Control.Tracer
import           Data.Foldable (traverse_)
import           Data.Functor ((<&>))
import           Data.Kind (Type)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe)
import           Data.Maybe.Strict (StrictMaybe (..))
import           Data.Proxy
import           Data.Typeable
import           Data.Word (Word64)
import           GHC.Generics (Generic)
import           GHC.Stack (HasCallStack)
import           Network.TypedProtocol.Core
import           NoThunks.Class (unsafeNoThunks)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime (RelativeTime)
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Forecast
import           Ouroboros.Consensus.HardFork.History
                     (PastHorizonException (PastHorizon))
import           Ouroboros.Consensus.HeaderStateHistory
                     (HeaderStateHistory (..), HeaderStateWithTime (..),
                     validateHeader)
import qualified Ouroboros.Consensus.HeaderStateHistory as HeaderStateHistory
import           Ouroboros.Consensus.HeaderValidation hiding (validateHeader)
import           Ouroboros.Consensus.Ledger.Basics
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck
                     (HistoricalChainSyncMessage (..), HistoricityCheck,
                     HistoricityException)
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as Jumping
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State
import           Ouroboros.Consensus.Node.GsmState (GsmState (..))
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Storage.ChainDB (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import           Ouroboros.Consensus.Util
import           Ouroboros.Consensus.Util.AnchoredFragment
                     (preferAnchoredCandidate)
import           Ouroboros.Consensus.Util.Assert (assertWithMsg)
import           Ouroboros.Consensus.Util.EarlyExit (WithEarlyExit, exitEarly)
import qualified Ouroboros.Consensus.Util.EarlyExit as EarlyExit
import           Ouroboros.Consensus.Util.IOLike hiding (handle)
import           Ouroboros.Consensus.Util.LeakyBucket
                     (atomicallyWithMonotonicTime)
import qualified Ouroboros.Consensus.Util.LeakyBucket as LeakyBucket
import           Ouroboros.Consensus.Util.STM (Fingerprint, Watcher (..),
                     WithFingerprint (..), withWatcher)
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
                     AnchoredSeq (..))
import qualified Ouroboros.Network.AnchoredFragment as AF
import qualified Ouroboros.Network.AnchoredSeq as AS
import           Ouroboros.Network.Block (Tip (..), getTipBlockNo)
import           Ouroboros.Network.ControlMessage (ControlMessage (..),
                     ControlMessageSTM)
import           Ouroboros.Network.PeerSelection.PeerMetric.Type
                     (HeaderMetricsTracer)
import           Ouroboros.Network.Protocol.ChainSync.ClientPipelined
import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision

-- | Merely a helpful abbreviation
type Consensus
        (client :: Type -> Type -> Type -> (Type -> Type) -> Type -> Type)
        blk
        m
  = client (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult

-- | Abstract over the ChainDB
data ChainDbView m blk = ChainDbView {
    forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (AnchoredFragment (Header blk))
getCurrentChain :: STM m (AnchoredFragment (Header blk))
  ,
    forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (HeaderStateHistory blk)
getHeaderStateHistory :: STM m (HeaderStateHistory blk)
  ,
    forall (m :: * -> *) blk.
ChainDbView m blk
-> Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
getPastLedger :: Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
  ,
    forall (m :: * -> *) blk.
ChainDbView m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock ::
      STM m
          (WithFingerprint
              (HeaderHash blk -> Maybe (ExtValidationError blk)))
  }

-- | Configuration of the leaky bucket when it is enabled.
data ChainSyncLoPBucketEnabledConfig = ChainSyncLoPBucketEnabledConfig {
    -- | The capacity of the bucket (think number of tokens).
    ChainSyncLoPBucketEnabledConfig -> Integer
csbcCapacity :: Integer,
    -- | The rate of the bucket (think tokens per second).
    ChainSyncLoPBucketEnabledConfig -> Rational
csbcRate     :: Rational
  } deriving stock (ChainSyncLoPBucketEnabledConfig
-> ChainSyncLoPBucketEnabledConfig -> Bool
(ChainSyncLoPBucketEnabledConfig
 -> ChainSyncLoPBucketEnabledConfig -> Bool)
-> (ChainSyncLoPBucketEnabledConfig
    -> ChainSyncLoPBucketEnabledConfig -> Bool)
-> Eq ChainSyncLoPBucketEnabledConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainSyncLoPBucketEnabledConfig
-> ChainSyncLoPBucketEnabledConfig -> Bool
== :: ChainSyncLoPBucketEnabledConfig
-> ChainSyncLoPBucketEnabledConfig -> Bool
$c/= :: ChainSyncLoPBucketEnabledConfig
-> ChainSyncLoPBucketEnabledConfig -> Bool
/= :: ChainSyncLoPBucketEnabledConfig
-> ChainSyncLoPBucketEnabledConfig -> Bool
Eq, (forall x.
 ChainSyncLoPBucketEnabledConfig
 -> Rep ChainSyncLoPBucketEnabledConfig x)
-> (forall x.
    Rep ChainSyncLoPBucketEnabledConfig x
    -> ChainSyncLoPBucketEnabledConfig)
-> Generic ChainSyncLoPBucketEnabledConfig
forall x.
Rep ChainSyncLoPBucketEnabledConfig x
-> ChainSyncLoPBucketEnabledConfig
forall x.
ChainSyncLoPBucketEnabledConfig
-> Rep ChainSyncLoPBucketEnabledConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
ChainSyncLoPBucketEnabledConfig
-> Rep ChainSyncLoPBucketEnabledConfig x
from :: forall x.
ChainSyncLoPBucketEnabledConfig
-> Rep ChainSyncLoPBucketEnabledConfig x
$cto :: forall x.
Rep ChainSyncLoPBucketEnabledConfig x
-> ChainSyncLoPBucketEnabledConfig
to :: forall x.
Rep ChainSyncLoPBucketEnabledConfig x
-> ChainSyncLoPBucketEnabledConfig
Generic, Int -> ChainSyncLoPBucketEnabledConfig -> ShowS
[ChainSyncLoPBucketEnabledConfig] -> ShowS
ChainSyncLoPBucketEnabledConfig -> String
(Int -> ChainSyncLoPBucketEnabledConfig -> ShowS)
-> (ChainSyncLoPBucketEnabledConfig -> String)
-> ([ChainSyncLoPBucketEnabledConfig] -> ShowS)
-> Show ChainSyncLoPBucketEnabledConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainSyncLoPBucketEnabledConfig -> ShowS
showsPrec :: Int -> ChainSyncLoPBucketEnabledConfig -> ShowS
$cshow :: ChainSyncLoPBucketEnabledConfig -> String
show :: ChainSyncLoPBucketEnabledConfig -> String
$cshowList :: [ChainSyncLoPBucketEnabledConfig] -> ShowS
showList :: [ChainSyncLoPBucketEnabledConfig] -> ShowS
Show)

-- | Configuration of the leaky bucket.
data ChainSyncLoPBucketConfig
  =
    -- | Fully disable the leaky bucket. The background thread that is used to
    -- run it will not even be started.
    ChainSyncLoPBucketDisabled
  |
    -- | Enable the leaky bucket.
    ChainSyncLoPBucketEnabled ChainSyncLoPBucketEnabledConfig
  deriving stock (ChainSyncLoPBucketConfig -> ChainSyncLoPBucketConfig -> Bool
(ChainSyncLoPBucketConfig -> ChainSyncLoPBucketConfig -> Bool)
-> (ChainSyncLoPBucketConfig -> ChainSyncLoPBucketConfig -> Bool)
-> Eq ChainSyncLoPBucketConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainSyncLoPBucketConfig -> ChainSyncLoPBucketConfig -> Bool
== :: ChainSyncLoPBucketConfig -> ChainSyncLoPBucketConfig -> Bool
$c/= :: ChainSyncLoPBucketConfig -> ChainSyncLoPBucketConfig -> Bool
/= :: ChainSyncLoPBucketConfig -> ChainSyncLoPBucketConfig -> Bool
Eq, (forall x.
 ChainSyncLoPBucketConfig -> Rep ChainSyncLoPBucketConfig x)
-> (forall x.
    Rep ChainSyncLoPBucketConfig x -> ChainSyncLoPBucketConfig)
-> Generic ChainSyncLoPBucketConfig
forall x.
Rep ChainSyncLoPBucketConfig x -> ChainSyncLoPBucketConfig
forall x.
ChainSyncLoPBucketConfig -> Rep ChainSyncLoPBucketConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
ChainSyncLoPBucketConfig -> Rep ChainSyncLoPBucketConfig x
from :: forall x.
ChainSyncLoPBucketConfig -> Rep ChainSyncLoPBucketConfig x
$cto :: forall x.
Rep ChainSyncLoPBucketConfig x -> ChainSyncLoPBucketConfig
to :: forall x.
Rep ChainSyncLoPBucketConfig x -> ChainSyncLoPBucketConfig
Generic, Int -> ChainSyncLoPBucketConfig -> ShowS
[ChainSyncLoPBucketConfig] -> ShowS
ChainSyncLoPBucketConfig -> String
(Int -> ChainSyncLoPBucketConfig -> ShowS)
-> (ChainSyncLoPBucketConfig -> String)
-> ([ChainSyncLoPBucketConfig] -> ShowS)
-> Show ChainSyncLoPBucketConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainSyncLoPBucketConfig -> ShowS
showsPrec :: Int -> ChainSyncLoPBucketConfig -> ShowS
$cshow :: ChainSyncLoPBucketConfig -> String
show :: ChainSyncLoPBucketConfig -> String
$cshowList :: [ChainSyncLoPBucketConfig] -> ShowS
showList :: [ChainSyncLoPBucketConfig] -> ShowS
Show)

-- | Configuration of ChainSync Jumping
data CSJConfig
  =
    -- | Disable ChainSync Jumping. All clients will fully synchronize with
    -- the chain of its peer.
    CSJDisabled
  |
    -- | Enable ChainSync Jumping
    CSJEnabled CSJEnabledConfig
  deriving stock (CSJConfig -> CSJConfig -> Bool
(CSJConfig -> CSJConfig -> Bool)
-> (CSJConfig -> CSJConfig -> Bool) -> Eq CSJConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CSJConfig -> CSJConfig -> Bool
== :: CSJConfig -> CSJConfig -> Bool
$c/= :: CSJConfig -> CSJConfig -> Bool
/= :: CSJConfig -> CSJConfig -> Bool
Eq, (forall x. CSJConfig -> Rep CSJConfig x)
-> (forall x. Rep CSJConfig x -> CSJConfig) -> Generic CSJConfig
forall x. Rep CSJConfig x -> CSJConfig
forall x. CSJConfig -> Rep CSJConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CSJConfig -> Rep CSJConfig x
from :: forall x. CSJConfig -> Rep CSJConfig x
$cto :: forall x. Rep CSJConfig x -> CSJConfig
to :: forall x. Rep CSJConfig x -> CSJConfig
Generic, Int -> CSJConfig -> ShowS
[CSJConfig] -> ShowS
CSJConfig -> String
(Int -> CSJConfig -> ShowS)
-> (CSJConfig -> String)
-> ([CSJConfig] -> ShowS)
-> Show CSJConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CSJConfig -> ShowS
showsPrec :: Int -> CSJConfig -> ShowS
$cshow :: CSJConfig -> String
show :: CSJConfig -> String
$cshowList :: [CSJConfig] -> ShowS
showList :: [CSJConfig] -> ShowS
Show)

newtype CSJEnabledConfig = CSJEnabledConfig {
  -- | The _ideal_ size for ChainSync jumps. Note that the algorithm
  -- is best-effort: there might not be exactly `csjcJumpSize` slots between two
  -- jumps, depending on the chain.
  --
  -- There can be a few less slots between jumps if there is not a block exactly
  -- at the boundary. Jumps are often made when a block is announced after the
  -- jump boundary.
  --
  -- There can be even less slots if a dynamo is elected and it requires an
  -- initial jump regardless of how far we are from the next jump boundary.
  --
  -- csjcJumpSize must be greater than 0 and smaller or equal to the genesis
  -- window size. The larger the jump size, the less jumps are made and peers
  -- are less involved in the syncing. A jump size as large as the genesis
  -- window has a higher change that dishonest peers can delay syncing by a
  -- small margin (around 2 minutes per dishonest peer with mainnet parameters).
  CSJEnabledConfig -> SlotNo
csjcJumpSize       :: SlotNo
} deriving stock (CSJEnabledConfig -> CSJEnabledConfig -> Bool
(CSJEnabledConfig -> CSJEnabledConfig -> Bool)
-> (CSJEnabledConfig -> CSJEnabledConfig -> Bool)
-> Eq CSJEnabledConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CSJEnabledConfig -> CSJEnabledConfig -> Bool
== :: CSJEnabledConfig -> CSJEnabledConfig -> Bool
$c/= :: CSJEnabledConfig -> CSJEnabledConfig -> Bool
/= :: CSJEnabledConfig -> CSJEnabledConfig -> Bool
Eq, (forall x. CSJEnabledConfig -> Rep CSJEnabledConfig x)
-> (forall x. Rep CSJEnabledConfig x -> CSJEnabledConfig)
-> Generic CSJEnabledConfig
forall x. Rep CSJEnabledConfig x -> CSJEnabledConfig
forall x. CSJEnabledConfig -> Rep CSJEnabledConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CSJEnabledConfig -> Rep CSJEnabledConfig x
from :: forall x. CSJEnabledConfig -> Rep CSJEnabledConfig x
$cto :: forall x. Rep CSJEnabledConfig x -> CSJEnabledConfig
to :: forall x. Rep CSJEnabledConfig x -> CSJEnabledConfig
Generic, Int -> CSJEnabledConfig -> ShowS
[CSJEnabledConfig] -> ShowS
CSJEnabledConfig -> String
(Int -> CSJEnabledConfig -> ShowS)
-> (CSJEnabledConfig -> String)
-> ([CSJEnabledConfig] -> ShowS)
-> Show CSJEnabledConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CSJEnabledConfig -> ShowS
showsPrec :: Int -> CSJEnabledConfig -> ShowS
$cshow :: CSJEnabledConfig -> String
show :: CSJEnabledConfig -> String
$cshowList :: [CSJEnabledConfig] -> ShowS
showList :: [CSJEnabledConfig] -> ShowS
Show)

defaultChainDbView ::
     ChainDB m blk -> ChainDbView m blk
defaultChainDbView :: forall (m :: * -> *) blk. ChainDB m blk -> ChainDbView m blk
defaultChainDbView ChainDB m blk
chainDB = ChainDbView {
    getCurrentChain :: STM m (AnchoredFragment (Header blk))
getCurrentChain       = ChainDB m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain       ChainDB m blk
chainDB
  , getHeaderStateHistory :: STM m (HeaderStateHistory blk)
getHeaderStateHistory = ChainDB m blk -> STM m (HeaderStateHistory blk)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (HeaderStateHistory blk)
ChainDB.getHeaderStateHistory ChainDB m blk
chainDB
  , getPastLedger :: Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
getPastLedger         = ChainDB m blk
-> Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
forall (m :: * -> *) blk.
ChainDB m blk
-> Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
ChainDB.getPastLedger         ChainDB m blk
chainDB
  , getIsInvalidBlock :: STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock     = ChainDB m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
forall (m :: * -> *) blk.
ChainDB m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
ChainDB.getIsInvalidBlock     ChainDB m blk
chainDB
  }

-- | A newtype wrapper to avoid confusing our tip with their tip.
newtype Their a = Their { forall a. Their a -> a
unTheir :: a }
  deriving stock   (Their a -> Their a -> Bool
(Their a -> Their a -> Bool)
-> (Their a -> Their a -> Bool) -> Eq (Their a)
forall a. Eq a => Their a -> Their a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Their a -> Their a -> Bool
== :: Their a -> Their a -> Bool
$c/= :: forall a. Eq a => Their a -> Their a -> Bool
/= :: Their a -> Their a -> Bool
Eq)
  deriving newtype (Int -> Their a -> ShowS
[Their a] -> ShowS
Their a -> String
(Int -> Their a -> ShowS)
-> (Their a -> String) -> ([Their a] -> ShowS) -> Show (Their a)
forall a. Show a => Int -> Their a -> ShowS
forall a. Show a => [Their a] -> ShowS
forall a. Show a => Their a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Their a -> ShowS
showsPrec :: Int -> Their a -> ShowS
$cshow :: forall a. Show a => Their a -> String
show :: Their a -> String
$cshowList :: forall a. Show a => [Their a] -> ShowS
showList :: [Their a] -> ShowS
Show, Context -> Their a -> IO (Maybe ThunkInfo)
Proxy (Their a) -> String
(Context -> Their a -> IO (Maybe ThunkInfo))
-> (Context -> Their a -> IO (Maybe ThunkInfo))
-> (Proxy (Their a) -> String)
-> NoThunks (Their a)
forall a. NoThunks a => Context -> Their a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Proxy (Their a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall a. NoThunks a => Context -> Their a -> IO (Maybe ThunkInfo)
noThunks :: Context -> Their a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a. NoThunks a => Context -> Their a -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Their a -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall a. NoThunks a => Proxy (Their a) -> String
showTypeOf :: Proxy (Their a) -> String
NoThunks)

-- | A newtype wrapper to avoid confusing our tip with their tip.
newtype Our a = Our { forall a. Our a -> a
unOur :: a }
  deriving stock   (Our a -> Our a -> Bool
(Our a -> Our a -> Bool) -> (Our a -> Our a -> Bool) -> Eq (Our a)
forall a. Eq a => Our a -> Our a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Our a -> Our a -> Bool
== :: Our a -> Our a -> Bool
$c/= :: forall a. Eq a => Our a -> Our a -> Bool
/= :: Our a -> Our a -> Bool
Eq)
  deriving newtype (Int -> Our a -> ShowS
[Our a] -> ShowS
Our a -> String
(Int -> Our a -> ShowS)
-> (Our a -> String) -> ([Our a] -> ShowS) -> Show (Our a)
forall a. Show a => Int -> Our a -> ShowS
forall a. Show a => [Our a] -> ShowS
forall a. Show a => Our a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Our a -> ShowS
showsPrec :: Int -> Our a -> ShowS
$cshow :: forall a. Show a => Our a -> String
show :: Our a -> String
$cshowList :: forall a. Show a => [Our a] -> ShowS
showList :: [Our a] -> ShowS
Show, Context -> Our a -> IO (Maybe ThunkInfo)
Proxy (Our a) -> String
(Context -> Our a -> IO (Maybe ThunkInfo))
-> (Context -> Our a -> IO (Maybe ThunkInfo))
-> (Proxy (Our a) -> String)
-> NoThunks (Our a)
forall a. NoThunks a => Context -> Our a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Proxy (Our a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall a. NoThunks a => Context -> Our a -> IO (Maybe ThunkInfo)
noThunks :: Context -> Our a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a. NoThunks a => Context -> Our a -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Our a -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall a. NoThunks a => Proxy (Our a) -> String
showTypeOf :: Proxy (Our a) -> String
NoThunks)

-- | Convenience function for reading a nested set of TVars and extracting some
-- data from 'ChainSyncState'.
viewChainSyncState ::
  IOLike m =>
  STM m (Map peer (ChainSyncClientHandle m blk)) ->
  (ChainSyncState blk -> a) ->
  STM m (Map peer a)
viewChainSyncState :: forall (m :: * -> *) peer blk a.
IOLike m =>
STM m (Map peer (ChainSyncClientHandle m blk))
-> (ChainSyncState blk -> a) -> STM m (Map peer a)
viewChainSyncState STM m (Map peer (ChainSyncClientHandle m blk))
readHandles ChainSyncState blk -> a
f =
  (ChainSyncState blk -> a)
-> Map peer (ChainSyncState blk) -> Map peer a
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ChainSyncState blk -> a
f (Map peer (ChainSyncState blk) -> Map peer a)
-> STM m (Map peer (ChainSyncState blk)) -> STM m (Map peer a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ChainSyncClientHandle m blk -> STM m (ChainSyncState blk))
-> Map peer (ChainSyncClientHandle m blk)
-> STM m (Map peer (ChainSyncState blk))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map peer a -> f (Map peer b)
traverse (StrictTVar m (ChainSyncState blk) -> STM m (ChainSyncState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (ChainSyncState blk) -> STM m (ChainSyncState blk))
-> (ChainSyncClientHandle m blk
    -> StrictTVar m (ChainSyncState blk))
-> ChainSyncClientHandle m blk
-> STM m (ChainSyncState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
cschState) (Map peer (ChainSyncClientHandle m blk)
 -> STM m (Map peer (ChainSyncState blk)))
-> STM m (Map peer (ChainSyncClientHandle m blk))
-> STM m (Map peer (ChainSyncState blk))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM m (Map peer (ChainSyncClientHandle m blk))
readHandles)

-- | Convenience function for reading the 'ChainSyncState' for a single peer
-- from a nested set of TVars.
chainSyncStateFor ::
  Ord peer =>
  IOLike m =>
  StrictTVar m (Map peer (ChainSyncClientHandle m blk)) ->
  peer ->
  STM m (ChainSyncState blk)
chainSyncStateFor :: forall peer (m :: * -> *) blk.
(Ord peer, IOLike m) =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> peer -> STM m (ChainSyncState blk)
chainSyncStateFor StrictTVar m (Map peer (ChainSyncClientHandle m blk))
varHandles peer
peer =
  StrictTVar m (ChainSyncState blk) -> STM m (ChainSyncState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (StrictTVar m (ChainSyncState blk) -> STM m (ChainSyncState blk))
-> (Map peer (ChainSyncClientHandle m blk)
    -> StrictTVar m (ChainSyncState blk))
-> Map peer (ChainSyncClientHandle m blk)
-> STM m (ChainSyncState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
forall (m :: * -> *) blk.
ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk)
cschState (ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk))
-> (Map peer (ChainSyncClientHandle m blk)
    -> ChainSyncClientHandle m blk)
-> Map peer (ChainSyncClientHandle m blk)
-> StrictTVar m (ChainSyncState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map peer (ChainSyncClientHandle m blk)
-> peer -> ChainSyncClientHandle m blk
forall k a. Ord k => Map k a -> k -> a
Map.! peer
peer) (Map peer (ChainSyncClientHandle m blk)
 -> STM m (ChainSyncState blk))
-> STM m (Map peer (ChainSyncClientHandle m blk))
-> STM m (ChainSyncState blk)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m 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))
varHandles

-- | Interface for the ChainSync client to manipulate the idling flag in
-- 'ChainSyncState'.
data Idling m = Idling {
    -- | Mark the peer as being idle.
    forall (m :: * -> *). Idling m -> m ()
idlingStart :: !(m ())

    -- | Mark the peer as not being idle.
  , forall (m :: * -> *). Idling m -> m ()
idlingStop  :: !(m ())
  }
  deriving stock ((forall x. Idling m -> Rep (Idling m) x)
-> (forall x. Rep (Idling m) x -> Idling m) -> Generic (Idling m)
forall x. Rep (Idling m) x -> Idling m
forall x. Idling m -> Rep (Idling m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) x. Rep (Idling m) x -> Idling m
forall (m :: * -> *) x. Idling m -> Rep (Idling m) x
$cfrom :: forall (m :: * -> *) x. Idling m -> Rep (Idling m) x
from :: forall x. Idling m -> Rep (Idling m) x
$cto :: forall (m :: * -> *) x. Rep (Idling m) x -> Idling m
to :: forall x. Rep (Idling m) x -> Idling m
Generic)

deriving anyclass instance IOLike m => NoThunks (Idling m)

-- | No-op implementation, for tests.
noIdling :: Applicative m => Idling m
noIdling :: forall (m :: * -> *). Applicative m => Idling m
noIdling =
  Idling {
      idlingStart :: m ()
idlingStart = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , idlingStop :: m ()
idlingStop  = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    }

-- | Interface to the LoP implementation for the ChainSync client.
data LoPBucket m = LoPBucket {
    -- | Pause the bucket, because the peer is alert and we're waiting for some
    -- condition.
    forall (m :: * -> *). LoPBucket m -> m ()
lbPause      :: !(m ())

    -- | Resume the bucket after pausing it.
  , forall (m :: * -> *). LoPBucket m -> m ()
lbResume     :: !(m ())

    -- | Notify the bucket that the peer has sent an interesting header.
  , forall (m :: * -> *). LoPBucket m -> m ()
lbGrantToken :: !(m ())
  }
  deriving stock ((forall x. LoPBucket m -> Rep (LoPBucket m) x)
-> (forall x. Rep (LoPBucket m) x -> LoPBucket m)
-> Generic (LoPBucket m)
forall x. Rep (LoPBucket m) x -> LoPBucket m
forall x. LoPBucket m -> Rep (LoPBucket m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) x. Rep (LoPBucket m) x -> LoPBucket m
forall (m :: * -> *) x. LoPBucket m -> Rep (LoPBucket m) x
$cfrom :: forall (m :: * -> *) x. LoPBucket m -> Rep (LoPBucket m) x
from :: forall x. LoPBucket m -> Rep (LoPBucket m) x
$cto :: forall (m :: * -> *) x. Rep (LoPBucket m) x -> LoPBucket m
to :: forall x. Rep (LoPBucket m) x -> LoPBucket m
Generic)

deriving anyclass instance IOLike m => NoThunks (LoPBucket m)

-- | No-op implementation, for tests.
noLoPBucket :: Applicative m => LoPBucket m
noLoPBucket :: forall (m :: * -> *). Applicative m => LoPBucket m
noLoPBucket =
  LoPBucket {
      lbPause :: m ()
lbPause      = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , lbResume :: m ()
lbResume     = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , lbGrantToken :: m ()
lbGrantToken = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    }

-- | Interface for the ChainSync client to its state allocated by
-- 'bracketChainSyncClient'.
data ChainSyncStateView m blk = ChainSyncStateView {
    -- | The current candidate fragment
    forall (m :: * -> *) blk.
ChainSyncStateView m blk
-> AnchoredFragment (HeaderWithTime blk) -> STM m ()
csvSetCandidate  :: !(AnchoredFragment (HeaderWithTime blk) -> STM m ())

    -- | Update the slot of the latest received header
  , forall (m :: * -> *) blk.
ChainSyncStateView m blk -> WithOrigin SlotNo -> STM m ()
csvSetLatestSlot :: !(WithOrigin SlotNo -> STM m ())

    -- | (Un)mark the peer as idling.
  , forall (m :: * -> *) blk. ChainSyncStateView m blk -> Idling m
csvIdling        :: !(Idling m)

    -- | Control the 'LeakyBucket' for the LoP.
  , forall (m :: * -> *) blk. ChainSyncStateView m blk -> LoPBucket m
csvLoPBucket     :: !(LoPBucket m)

    -- | Jumping-related API.
  , forall (m :: * -> *) blk. ChainSyncStateView m blk -> Jumping m blk
csvJumping       :: !(Jumping.Jumping m blk)
  }
  deriving stock ((forall x.
 ChainSyncStateView m blk -> Rep (ChainSyncStateView m blk) x)
-> (forall x.
    Rep (ChainSyncStateView m blk) x -> ChainSyncStateView m blk)
-> Generic (ChainSyncStateView m blk)
forall x.
Rep (ChainSyncStateView m blk) x -> ChainSyncStateView m blk
forall x.
ChainSyncStateView m blk -> Rep (ChainSyncStateView m blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) blk x.
Rep (ChainSyncStateView m blk) x -> ChainSyncStateView m blk
forall (m :: * -> *) blk x.
ChainSyncStateView m blk -> Rep (ChainSyncStateView m blk) x
$cfrom :: forall (m :: * -> *) blk x.
ChainSyncStateView m blk -> Rep (ChainSyncStateView m blk) x
from :: forall x.
ChainSyncStateView m blk -> Rep (ChainSyncStateView m blk) x
$cto :: forall (m :: * -> *) blk x.
Rep (ChainSyncStateView m blk) x -> ChainSyncStateView m blk
to :: forall x.
Rep (ChainSyncStateView m blk) x -> ChainSyncStateView m blk
Generic)

deriving anyclass instance (
  IOLike m,
  HasHeader blk,
  NoThunks (Header blk)
  ) => NoThunks (ChainSyncStateView m blk)

bracketChainSyncClient ::
  forall m peer blk a.
    ( IOLike m
    , Ord peer
    , LedgerSupportsProtocol blk
    , MonadTimer m
    )
 => Tracer m (TraceChainSyncClientEvent blk)
 -> Tracer m (Jumping.TraceEventCsj peer blk)
 -> ChainDbView m blk
 -> ChainSyncClientHandleCollection peer m blk
    -- ^ The kill handle and states for each peer, we need the whole map because we
    -- (de)register nodes (@peer@).
 -> STM m GsmState
    -- ^ A function giving the current GSM state; only used at startup.
 -> peer
 -> NodeToNodeVersion
 -> ChainSyncLoPBucketConfig
 -> CSJConfig
 -> DiffusionPipeliningSupport
 -> (ChainSyncStateView m blk -> m a)
 -> m a
bracketChainSyncClient :: forall (m :: * -> *) peer blk a.
(IOLike m, Ord peer, LedgerSupportsProtocol blk, MonadTimer m) =>
Tracer m (TraceChainSyncClientEvent blk)
-> Tracer m (TraceEventCsj peer blk)
-> ChainDbView m blk
-> ChainSyncClientHandleCollection peer m blk
-> STM m GsmState
-> peer
-> NodeToNodeVersion
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> DiffusionPipeliningSupport
-> (ChainSyncStateView m blk -> m a)
-> m a
bracketChainSyncClient
    Tracer m (TraceChainSyncClientEvent blk)
tracer
    Tracer m (TraceEventCsj peer blk)
tracerCsj
    ChainDbView { STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock :: forall (m :: * -> *) blk.
ChainDbView m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock :: STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock }
    ChainSyncClientHandleCollection peer m blk
varHandles
    STM m GsmState
getGsmState
    peer
peer
    NodeToNodeVersion
version
    ChainSyncLoPBucketConfig
csBucketConfig
    CSJConfig
csjConfig
    DiffusionPipeliningSupport
pipelining
    ChainSyncStateView m blk -> m a
body
  =
    (Handlers m -> m a) -> m a
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
(Handlers m -> m a) -> m a
LeakyBucket.execAgainstBucket'
  ((Handlers m -> m a) -> m a) -> (Handlers m -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Handlers m
lopBucket ->
    m (StrictTVar m (ChainSyncState blk))
mkChainSyncClientHandleState m (StrictTVar m (ChainSyncState blk))
-> (StrictTVar m (ChainSyncState blk) -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \StrictTVar m (ChainSyncState blk)
csHandleState ->
    Handlers m
-> StrictTVar m (ChainSyncState blk)
-> CSJConfig
-> (Jumping m blk -> m a)
-> m a
withCSJCallbacks Handlers m
lopBucket StrictTVar m (ChainSyncState blk)
csHandleState CSJConfig
csjConfig ((Jumping m blk -> m a) -> m a) -> (Jumping m blk -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Jumping m blk
csjCallbacks ->
        String
-> Watcher
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
     Fingerprint
-> m a
-> m a
forall (m :: * -> *) a fp r.
(IOLike m, Eq fp, HasCallStack) =>
String -> Watcher m a fp -> m r -> m r
withWatcher
            String
"ChainSync.Client.rejectInvalidBlocks"
            (StrictTVar m (ChainSyncState blk)
-> Watcher
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
     Fingerprint
invalidBlockWatcher StrictTVar m (ChainSyncState blk)
csHandleState)
      (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ ChainSyncStateView m blk -> m a
body ChainSyncStateView {
              csvSetCandidate :: AnchoredFragment (HeaderWithTime blk) -> STM m ()
csvSetCandidate =
              StrictTVar m (ChainSyncState blk)
-> (ChainSyncState blk -> ChainSyncState blk) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (ChainSyncState blk)
csHandleState ((ChainSyncState blk -> ChainSyncState blk) -> STM m ())
-> (AnchoredFragment (HeaderWithTime blk)
    -> ChainSyncState blk -> ChainSyncState blk)
-> AnchoredFragment (HeaderWithTime blk)
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \ AnchoredFragment (HeaderWithTime blk)
c ChainSyncState blk
s -> ChainSyncState blk
s {csCandidate = c}
            , csvSetLatestSlot :: WithOrigin SlotNo -> STM m ()
csvSetLatestSlot =
              StrictTVar m (ChainSyncState blk)
-> (ChainSyncState blk -> ChainSyncState blk) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (ChainSyncState blk)
csHandleState ((ChainSyncState blk -> ChainSyncState blk) -> STM m ())
-> (WithOrigin SlotNo -> ChainSyncState blk -> ChainSyncState blk)
-> WithOrigin SlotNo
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \ WithOrigin SlotNo
ls ChainSyncState blk
s -> ChainSyncState blk
s {csLatestSlot = SJust ls}
            , csvIdling :: Idling m
csvIdling = Idling {
                idlingStart :: m ()
idlingStart = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (ChainSyncState blk)
-> (ChainSyncState blk -> ChainSyncState blk) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (ChainSyncState blk)
csHandleState ((ChainSyncState blk -> ChainSyncState blk) -> STM m ())
-> (ChainSyncState blk -> ChainSyncState blk) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \ ChainSyncState blk
s -> ChainSyncState blk
s {csIdling = True}
              , idlingStop :: m ()
idlingStop = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (ChainSyncState blk)
-> (ChainSyncState blk -> ChainSyncState blk) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (ChainSyncState blk)
csHandleState ((ChainSyncState blk -> ChainSyncState blk) -> STM m ())
-> (ChainSyncState blk -> ChainSyncState blk) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \ ChainSyncState blk
s -> ChainSyncState blk
s {csIdling = False}
              }
            , csvLoPBucket :: LoPBucket m
csvLoPBucket = LoPBucket {
                lbPause :: m ()
lbPause = Handlers m -> Bool -> m ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
LeakyBucket.setPaused' Handlers m
lopBucket Bool
True
              , lbResume :: m ()
lbResume = Handlers m -> Bool -> m ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
LeakyBucket.setPaused' Handlers m
lopBucket Bool
False
              , lbGrantToken :: m ()
lbGrantToken = m FillResult -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m FillResult -> m ()) -> m FillResult -> m ()
forall a b. (a -> b) -> a -> b
$ Handlers m -> Rational -> m FillResult
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Rational -> m FillResult
LeakyBucket.fill' Handlers m
lopBucket Rational
1
              }
            , csvJumping :: Jumping m blk
csvJumping = Jumping m blk
csjCallbacks
            }
  where
    mkChainSyncClientHandleState :: m (StrictTVar m (ChainSyncState blk))
mkChainSyncClientHandleState =
      ChainSyncState blk -> m (StrictTVar m (ChainSyncState blk))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO ChainSyncState {
          csCandidate :: AnchoredFragment (HeaderWithTime blk)
csCandidate = Anchor (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (HeaderWithTime blk)
forall block. Anchor block
AF.AnchorGenesis
        , csLatestSlot :: StrictMaybe (WithOrigin SlotNo)
csLatestSlot = StrictMaybe (WithOrigin SlotNo)
forall a. StrictMaybe a
SNothing
        , csIdling :: Bool
csIdling = Bool
False
        }

    withCSJCallbacks ::
      LeakyBucket.Handlers m ->
      StrictTVar m (ChainSyncState blk) ->
      CSJConfig ->
      (Jumping.Jumping m blk -> m a) ->
      m a
    withCSJCallbacks :: Handlers m
-> StrictTVar m (ChainSyncState blk)
-> CSJConfig
-> (Jumping m blk -> m a)
-> m a
withCSJCallbacks Handlers m
lopBucket StrictTVar m (ChainSyncState blk)
cschState CSJConfig
CSJDisabled Jumping m blk -> m a
f = do
      tid <- m (ThreadId m)
forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
      cschJumpInfo <- newTVarIO Nothing
      cschJumping <- newTVarIO (Disengaged DisengagedDone)
      let handle = ChainSyncClientHandle {
              cschGDDKill :: m ()
cschGDDKill = ThreadId m -> ChainSyncClientException -> m ()
forall e. Exception e => ThreadId m -> e -> m ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tid ChainSyncClientException
DensityTooLow
            , cschOnGsmStateChanged :: GsmState -> Time -> STM m ()
cschOnGsmStateChanged = Handlers m -> GsmState -> Time -> STM m ()
updateLopBucketConfig Handlers m
lopBucket
            , StrictTVar m (ChainSyncState blk)
cschState :: StrictTVar m (ChainSyncState blk)
cschState :: StrictTVar m (ChainSyncState blk)
cschState
            , StrictTVar m (ChainSyncJumpingState m blk)
cschJumping :: StrictTVar m (ChainSyncJumpingState m blk)
cschJumping :: StrictTVar m (ChainSyncJumpingState m blk)
cschJumping
            , StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo :: StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo :: StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo
            }
          insertHandle = (Time -> STM m ()) -> m ()
forall (m :: * -> *) b.
(MonadMonotonicTime m, MonadSTM m) =>
(Time -> STM m b) -> m b
atomicallyWithMonotonicTime ((Time -> STM m ()) -> m ()) -> (Time -> STM m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Time
time -> do
            initialGsmState <- STM m GsmState
getGsmState
            updateLopBucketConfig lopBucket initialGsmState time
            cschcAddHandle varHandles peer handle
          deleteHandle = 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
$ ChainSyncClientHandleCollection peer m blk -> peer -> STM m ()
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk -> peer -> STM m ()
cschcRemoveHandle ChainSyncClientHandleCollection peer m blk
varHandles peer
peer
      bracket_ insertHandle deleteHandle $ f Jumping.noJumping

    withCSJCallbacks Handlers m
lopBucket StrictTVar m (ChainSyncState blk)
csHandleState (CSJEnabled CSJEnabledConfig
csjEnabledConfig) Jumping m blk -> m a
f =
      m (PeerContext m peer blk, Maybe (TraceEventCsj peer blk))
-> ((PeerContext m peer blk, Maybe (TraceEventCsj peer blk))
    -> m ())
-> ((PeerContext m peer blk, Maybe (TraceEventCsj peer blk))
    -> m a)
-> m a
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Handlers m
-> StrictTVar m (ChainSyncState blk)
-> CSJEnabledConfig
-> m (PeerContext m peer blk, Maybe (TraceEventCsj peer blk))
acquireContext Handlers m
lopBucket StrictTVar m (ChainSyncState blk)
csHandleState CSJEnabledConfig
csjEnabledConfig) (PeerContext m peer blk, Maybe (TraceEventCsj peer blk)) -> m ()
forall {m :: * -> *} {blk} {peer} {b}.
(MonadSTM m, LedgerSupportsProtocol blk,
 IndexedMemPack (LedgerState blk EmptyMK) (TxOut (LedgerState blk)),
 Ord peer) =>
(PeerContext m peer blk, b) -> m ()
releaseContext (((PeerContext m peer blk, Maybe (TraceEventCsj peer blk)) -> m a)
 -> m a)
-> ((PeerContext m peer blk, Maybe (TraceEventCsj peer blk))
    -> m a)
-> m a
forall a b. (a -> b) -> a -> b
$ \(PeerContext m peer blk
peerContext, Maybe (TraceEventCsj peer blk)
mbEv) -> do
        (TraceEventCsj peer blk -> m ())
-> Maybe (TraceEventCsj peer blk) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Tracer m (TraceEventCsj peer blk) -> TraceEventCsj peer blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (PeerContext m peer blk -> Tracer m (TraceEventCsj peer blk)
forall peerField handleField (m :: * -> *) peer blk.
ContextWith peerField handleField m peer blk
-> Tracer m (TraceEventCsj peer blk)
Jumping.tracer PeerContext m peer blk
peerContext)) Maybe (TraceEventCsj peer blk)
mbEv
        Jumping m blk -> m a
f (Jumping m blk -> m a) -> Jumping m blk -> m a
forall a b. (a -> b) -> a -> b
$ PeerContext m peer blk -> Jumping m blk
forall (m :: * -> *) peer blk.
(MonadSTM m, Eq peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> Jumping m blk
Jumping.mkJumping PeerContext m peer blk
peerContext

    acquireContext :: Handlers m
-> StrictTVar m (ChainSyncState blk)
-> CSJEnabledConfig
-> m (PeerContext m peer blk, Maybe (TraceEventCsj peer blk))
acquireContext Handlers m
lopBucket StrictTVar m (ChainSyncState blk)
cschState (CSJEnabledConfig SlotNo
jumpSize) = do
        tid <- m (ThreadId m)
forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
        atomicallyWithMonotonicTime $ \Time
time -> do
          initialGsmState <- STM m GsmState
getGsmState
          updateLopBucketConfig lopBucket initialGsmState time
          cschJumpInfo <- newTVar Nothing
          context <- Jumping.makeContext varHandles jumpSize tracerCsj
          Jumping.registerClient context peer cschState $ \StrictTVar m (ChainSyncJumpingState m blk)
cschJumping -> ChainSyncClientHandle
            { cschGDDKill :: m ()
cschGDDKill = ThreadId m -> ChainSyncClientException -> m ()
forall e. Exception e => ThreadId m -> e -> m ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tid ChainSyncClientException
DensityTooLow
            , cschOnGsmStateChanged :: GsmState -> Time -> STM m ()
cschOnGsmStateChanged = Handlers m -> GsmState -> Time -> STM m ()
updateLopBucketConfig Handlers m
lopBucket
            , StrictTVar m (ChainSyncState blk)
cschState :: StrictTVar m (ChainSyncState blk)
cschState :: StrictTVar m (ChainSyncState blk)
cschState
            , StrictTVar m (ChainSyncJumpingState m blk)
cschJumping :: StrictTVar m (ChainSyncJumpingState m blk)
cschJumping :: StrictTVar m (ChainSyncJumpingState m blk)
cschJumping
            , StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo :: StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo :: StrictTVar m (Maybe (JumpInfo blk))
cschJumpInfo
            }

    releaseContext :: (PeerContext m peer blk, b) -> m ()
releaseContext (PeerContext m peer blk
peerContext, b
_mbEv) = do
        mbEv <- STM m (Maybe (TraceEventCsj peer blk))
-> m (Maybe (TraceEventCsj peer blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (TraceEventCsj peer blk))
 -> m (Maybe (TraceEventCsj peer blk)))
-> STM m (Maybe (TraceEventCsj peer blk))
-> m (Maybe (TraceEventCsj peer blk))
forall a b. (a -> b) -> a -> b
$ PeerContext m peer blk -> STM m (Maybe (TraceEventCsj peer blk))
forall (m :: * -> *) peer blk.
(MonadSTM m, Ord peer, LedgerSupportsProtocol blk) =>
PeerContext m peer blk -> STM m (Maybe (TraceEventCsj peer blk))
Jumping.unregisterClient PeerContext m peer blk
peerContext
        traverse_ (traceWith (Jumping.tracer peerContext)) mbEv

    invalidBlockWatcher :: StrictTVar m (ChainSyncState blk)
-> Watcher
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
     Fingerprint
invalidBlockWatcher StrictTVar m (ChainSyncState blk)
varState =
        Tracer m (TraceChainSyncClientEvent blk)
-> NodeToNodeVersion
-> DiffusionPipeliningSupport
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
-> STM m (AnchoredFragment (HeaderWithTime blk))
-> Watcher
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
     Fingerprint
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
Tracer m (TraceChainSyncClientEvent blk)
-> NodeToNodeVersion
-> DiffusionPipeliningSupport
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
-> STM m (AnchoredFragment (HeaderWithTime blk))
-> Watcher
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
     Fingerprint
invalidBlockRejector
            Tracer m (TraceChainSyncClientEvent blk)
tracer NodeToNodeVersion
version DiffusionPipeliningSupport
pipelining STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock (ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk)
forall blk.
ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk)
csCandidate (ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk))
-> STM m (ChainSyncState blk)
-> STM m (AnchoredFragment (HeaderWithTime blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (ChainSyncState blk) -> STM m (ChainSyncState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainSyncState blk)
varState)

    -- | Update the configuration of the bucket to match the given GSM state.
    -- NOTE: The new level is currently the maximal capacity of the bucket;
    -- maybe we want to change that later.
    updateLopBucketConfig :: LeakyBucket.Handlers m -> GsmState -> Time -> STM m ()
    updateLopBucketConfig :: Handlers m -> GsmState -> Time -> STM m ()
updateLopBucketConfig Handlers m
lopBucket GsmState
gsmState =
      Handlers m
-> ((Rational, Config m) -> (Rational, Config m))
-> Time
-> STM m ()
forall (m :: * -> *).
Handlers m
-> ((Rational, Config m) -> (Rational, Config m))
-> Time
-> STM m ()
LeakyBucket.updateConfig Handlers m
lopBucket (((Rational, Config m) -> (Rational, Config m))
 -> Time -> STM m ())
-> ((Rational, Config m) -> (Rational, Config m))
-> Time
-> STM m ()
forall a b. (a -> b) -> a -> b
$ \(Rational, Config m)
_ ->
        let config :: Config m
config = GsmState -> Config m
lopBucketConfig GsmState
gsmState in
          (Config m -> Rational
forall (m :: * -> *). Config m -> Rational
LeakyBucket.capacity Config m
config, Config m
config)

    -- | Wrapper around 'LeakyBucket.execAgainstBucket' that handles the
    -- disabled bucket by running the given action with dummy handlers.
    lopBucketConfig :: GsmState -> LeakyBucket.Config m
    lopBucketConfig :: GsmState -> Config m
lopBucketConfig GsmState
gsmState =
      case (GsmState
gsmState, ChainSyncLoPBucketConfig
csBucketConfig) of
        (GsmState
Syncing, ChainSyncLoPBucketEnabled ChainSyncLoPBucketEnabledConfig {Integer
csbcCapacity :: ChainSyncLoPBucketEnabledConfig -> Integer
csbcCapacity :: Integer
csbcCapacity, Rational
csbcRate :: ChainSyncLoPBucketEnabledConfig -> Rational
csbcRate :: Rational
csbcRate}) ->
            LeakyBucket.Config
              { capacity :: Rational
capacity = Integer -> Rational
forall a. Num a => Integer -> a
fromInteger (Integer -> Rational) -> Integer -> Rational
forall a b. (a -> b) -> a -> b
$ Integer
csbcCapacity,
                rate :: Rational
rate = Rational
csbcRate,
                onEmpty :: m ()
onEmpty = ChainSyncClientException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ChainSyncClientException
EmptyBucket,
                fillOnOverflow :: Bool
fillOnOverflow = Bool
True
              }
        -- NOTE: If we decide to slow the bucket down when “almost caught-up”,
        -- we should add a state to the GSM and corresponding configuration
        -- fields and a bucket config here.
        (GsmState
_, ChainSyncLoPBucketConfig
ChainSyncLoPBucketDisabled) -> Config m
forall (m :: * -> *). Applicative m => Config m
LeakyBucket.dummyConfig
        (GsmState
PreSyncing, ChainSyncLoPBucketEnabled ChainSyncLoPBucketEnabledConfig
_) -> Config m
forall (m :: * -> *). Applicative m => Config m
LeakyBucket.dummyConfig
        (GsmState
CaughtUp, ChainSyncLoPBucketEnabled ChainSyncLoPBucketEnabledConfig
_) -> Config m
forall (m :: * -> *). Applicative m => Config m
LeakyBucket.dummyConfig

-- Our task: after connecting to an upstream node, try to maintain an
-- up-to-date header-only fragment representing their chain. We maintain
-- such candidate fragments in a map with upstream nodes as keys.
--
-- The block fetch logic will use these candidate fragments to download
-- blocks from, prioritising certain candidate fragments over others using
-- the consensus protocol. Whenever such a block has been downloaded and
-- added to the local 'ChainDB', the 'ChainDB' will perform chain
-- selection.
--
-- We also validate the headers of a candidate fragment by advancing the
-- 'ChainDepState' with the headers, which returns an error when validation
-- failed. Thus, in addition to the chain fragment of each candidate, we also
-- store a 'ChainDepState' corresponding to the head of the candidate fragment.
--
-- We must keep the candidate fragment synchronised with the corresponding
-- upstream chain. The upstream node's chain might roll forward or
-- backwards, and they will inform us about this. When we get these
-- messages, we will replicate these actions on the candidate fragment.
--
-- INVARIANT:
--
-- >           our tip
-- >             v
-- >   /--* .... *
-- >   |
-- > --*
-- >   |
-- >   \--* .... *
-- >        fragment tip
--
-- The distance from our tip to the intersection between our chain and the
-- fragment maintained for the upstream node cannot exceed @k@ blocks. When
-- this invariant cannot be maintained, the upstream node is on a fork that
-- is too distant and we should disconnect.
--
-- TODO #423 rate-limit switching chains, otherwise we can't place blame (we
-- don't know which candidate's chain included the point that was
-- poisoned). E.g. two rollbacks per time slot -> make it configurable ->
-- just a simple argument for now.
--
-- TODO #467 if the 'theirTip' that they sent us is on our chain, just
-- switch to it.


-- = Candidate fragment size
-- -------------------------
--
-- The size of the downloaded candidate fragment ('theirFrag') and the
-- corresponding header state history ('theirHeaderStateHistory', which has the
-- same size as 'theirFrag') is limited by how far in the future the ledger
-- view can forecast.
--
-- For PBFT (Byron), we can forecast up to @2k@ slots ahead. Assuming a chain
-- density of 100%, this means the look-ahead is @2k@ headers. For mainnet this
-- means @2 * 2160 = 4320@ headers.
--
-- For TPraos (Shelley), we can forecast up to @3k/f@ slots ahead. Assuming a
-- density of @f@, this means the look-ahead is @3k@ headers. For mainnet, this
-- means @3 * 2160 = 6480@ headers.
--
-- The figure below shows the relation between 'ourFrag' and 'theirFrag':
--
-- >                       k headers or less, when A is genesis
-- >              <--------------------->
-- >            anchor    header       tip
-- >              |         |           |
-- >              V         V           V
-- > 'ourFrag':   A-H-H-H-H-H-H-H-H-...-H
-- >                     \
-- > 'theirFrag':         H-H-H-H-...   ...   ...
-- >                    ^
-- >                    |
-- >           most recent intersection (between A and the tip)
--
-- Note that the 'ourFrag' and 'theirFrag' share anchors /at all times/. In the
-- figure above, the first three headers on 'ourFrag' are thus also on
-- 'theirFrag'. The further away the most recent intersection is from the
-- anchor point, the more headers 'theirFrag' and 'ourFrag' will have in
-- common.
--
-- In the \"worst\" case 'theirFrag' has the following length:
--
-- >                        k
-- >              <--------------------->
-- > 'ourFrag':   A-H-H-H-H-H-H-H-H-...-H
-- >                                    \
-- > 'theirFrag':                        H-H-H-H-H-H-H-H-H-H-H-H-H-H-H...-H
-- >                                     <-------------------------------->
-- >                                               max look-ahead
-- > max length   <------------------------------------------------------->
-- > of 'theirFrag'         k + max look-ahead
--
-- For PBFT this is @2160 + 4320 = 6480@ headers, for TPraos this is @2160 +
-- 6480 = 8640@ headers. The header state history will have the same length.
--
-- This worst case can happen when:
-- * We are more than 6480 or respectively 8640 blocks behind, bulk syncing,
--   and the BlockFetch client and/or the ChainDB can't keep up with the
--   ChainSync client.
-- * When our clock is running behind such that we are not adopting the
--   corresponding blocks because we think they are from the future.
-- * When an attacker is serving us headers from the future.
--
-- When we are in sync with the network, the fragment will typically be @k@ to
-- @k + 1@ headers long.

-- | State used when the intersection between the candidate and the current
-- chain is unknown.
data UnknownIntersectionState blk = UnknownIntersectionState {
    forall blk.
UnknownIntersectionState blk -> AnchoredFragment (Header blk)
ourFrag               :: !(AnchoredFragment (Header blk))
    -- ^ A view of the current chain fragment. Note that this might be
    -- temporarily out of date w.r.t. the actual current chain until we update
    -- it again.
    --
    -- This fragment is used to select points from to find an intersection
    -- with the candidate.
    --
    -- INVARIANT: 'ourFrag' contains @k@ headers, unless close to genesis.
  ,
    forall blk. UnknownIntersectionState blk -> HeaderStateHistory blk
ourHeaderStateHistory :: !(HeaderStateHistory blk)
    -- ^ 'HeaderStateHistory' corresponding to the tip (most recent block) of
    -- 'ourFrag'.
  ,
    forall blk. UnknownIntersectionState blk -> BlockNo
uBestBlockNo          :: !BlockNo
    -- ^ The best block number of any header sent by this peer, to be used by
    -- the limit on patience.
  }
  deriving ((forall x.
 UnknownIntersectionState blk
 -> Rep (UnknownIntersectionState blk) x)
-> (forall x.
    Rep (UnknownIntersectionState blk) x
    -> UnknownIntersectionState blk)
-> Generic (UnknownIntersectionState blk)
forall x.
Rep (UnknownIntersectionState blk) x
-> UnknownIntersectionState blk
forall x.
UnknownIntersectionState blk
-> Rep (UnknownIntersectionState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (UnknownIntersectionState blk) x
-> UnknownIntersectionState blk
forall blk x.
UnknownIntersectionState blk
-> Rep (UnknownIntersectionState blk) x
$cfrom :: forall blk x.
UnknownIntersectionState blk
-> Rep (UnknownIntersectionState blk) x
from :: forall x.
UnknownIntersectionState blk
-> Rep (UnknownIntersectionState blk) x
$cto :: forall blk x.
Rep (UnknownIntersectionState blk) x
-> UnknownIntersectionState blk
to :: forall x.
Rep (UnknownIntersectionState blk) x
-> UnknownIntersectionState blk
Generic)

instance
     LedgerSupportsProtocol blk
  => NoThunks (UnknownIntersectionState blk) where
    showTypeOf :: Proxy (UnknownIntersectionState blk) -> String
showTypeOf Proxy (UnknownIntersectionState blk)
_ = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy (UnknownIntersectionState blk) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(UnknownIntersectionState blk))

-- | State used when the intersection between the candidate and the current
-- chain is known.
data KnownIntersectionState blk = KnownIntersectionState {
    forall blk. KnownIntersectionState blk -> Point blk
mostRecentIntersection  :: !(Point blk)
    -- ^ The most recent intersection point between 'theirFrag' and 'ourFrag'.
    -- Note that this is not necessarily the anchor point of both 'theirFrag'
    -- and 'ourFrag', they might have many more headers in common.
    --
    -- INVARIANT:
    -- @
    -- (==)
    --     (Just 'mostRecentIntersection')
    --     ('AF.intersectionPoint' 'theirFrag' 'ourFrag')
    -- @
    --
    -- It follows from the invariants on 'ourFrag' that this point is within
    -- the last @k@ headers of the current chain fragment, at time of
    -- computing the 'KnownIntersectionState'.
  ,
    forall blk.
KnownIntersectionState blk -> AnchoredFragment (Header blk)
ourFrag                 :: !(AnchoredFragment (Header blk))
    -- ^ A view of the current chain fragment used to maintain the invariants
    -- with. Note that this might be temporarily out of date w.r.t. the actual
    -- current chain until we update it again.
    --
    -- INVARIANT: 'ourFrag' contains @k@ headers, unless close to genesis.
    --
    -- INVARIANT: 'theirFrag' and 'ourFrag' have the same anchor point. From
    -- this follows that both fragments intersect. This also means that
    -- 'theirFrag' forks off within the last @k@ headers/blocks of the
    -- 'ourFrag'.
  ,
    forall blk.
KnownIntersectionState blk -> AnchoredFragment (HeaderWithTime blk)
theirFrag               :: !(AnchoredFragment (HeaderWithTime blk))
    -- ^ The candidate, the synched fragment of their chain.
    --
    -- See the \"Candidate fragment size\" note above.
  ,
    forall blk. KnownIntersectionState blk -> HeaderStateHistory blk
theirHeaderStateHistory :: !(HeaderStateHistory blk)
    -- ^ 'HeaderStateHistory' corresponding to the tip (most recent block) of
    -- 'theirFrag'.
    --
    -- INVARIANT: the tips in 'theirHeaderStateHistory' correspond to the
    -- headers in 'theirFrag', including the anchor.
    --
    -- See the \"Candidate fragment size\" note above.
  ,
    forall blk. KnownIntersectionState blk -> BlockNo
kBestBlockNo            :: !BlockNo
    -- ^ The best block number of any header sent by this peer, to be used by
    -- the limit on patience.
  }
  deriving ((forall x.
 KnownIntersectionState blk -> Rep (KnownIntersectionState blk) x)
-> (forall x.
    Rep (KnownIntersectionState blk) x -> KnownIntersectionState blk)
-> Generic (KnownIntersectionState blk)
forall x.
Rep (KnownIntersectionState blk) x -> KnownIntersectionState blk
forall x.
KnownIntersectionState blk -> Rep (KnownIntersectionState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (KnownIntersectionState blk) x -> KnownIntersectionState blk
forall blk x.
KnownIntersectionState blk -> Rep (KnownIntersectionState blk) x
$cfrom :: forall blk x.
KnownIntersectionState blk -> Rep (KnownIntersectionState blk) x
from :: forall x.
KnownIntersectionState blk -> Rep (KnownIntersectionState blk) x
$cto :: forall blk x.
Rep (KnownIntersectionState blk) x -> KnownIntersectionState blk
to :: forall x.
Rep (KnownIntersectionState blk) x -> KnownIntersectionState blk
Generic)

instance
     LedgerSupportsProtocol blk
  => NoThunks (KnownIntersectionState blk) where
    showTypeOf :: Proxy (KnownIntersectionState blk) -> String
showTypeOf Proxy (KnownIntersectionState blk)
_ = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy (KnownIntersectionState blk) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(KnownIntersectionState blk))

checkKnownIntersectionInvariants :: forall blk.
    ( HasHeader blk
    , HasHeader (Header blk)
    , HasAnnTip blk
    , ConsensusProtocol (BlockProtocol blk)
    )
 => ConsensusConfig (BlockProtocol blk)
 -> KnownIntersectionState blk
 -> Either String ()
checkKnownIntersectionInvariants :: forall blk.
(HasHeader blk, HasHeader (Header blk), HasAnnTip blk,
 ConsensusProtocol (BlockProtocol blk)) =>
ConsensusConfig (BlockProtocol blk)
-> KnownIntersectionState blk -> Either String ()
checkKnownIntersectionInvariants ConsensusConfig (BlockProtocol blk)
cfg KnownIntersectionState blk
kis
    -- 'theirHeaderStateHistory' invariant
    | let HeaderStateHistory AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
snapshots = HeaderStateHistory blk
theirHeaderStateHistory
          historyTips :: [WithOrigin (AnnTip blk)]
          historyTips :: [WithOrigin (AnnTip blk)]
historyTips  = HeaderState blk -> WithOrigin (AnnTip blk)
forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
headerStateTip (HeaderState blk -> WithOrigin (AnnTip blk))
-> (HeaderStateWithTime blk -> HeaderState blk)
-> HeaderStateWithTime blk
-> WithOrigin (AnnTip blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderStateWithTime blk -> HeaderState blk
forall blk. HeaderStateWithTime blk -> HeaderState blk
hswtHeaderState (HeaderStateWithTime blk -> WithOrigin (AnnTip blk))
-> [HeaderStateWithTime blk] -> [WithOrigin (AnnTip blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> [HeaderStateWithTime blk]
forall v a b. AnchoredSeq v a b -> [b]
AS.toOldestFirst AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
snapshots
          fragmentTips :: [WithOrigin (AnnTip blk)]
          fragmentTips :: [WithOrigin (AnnTip blk)]
fragmentTips = AnnTip blk -> WithOrigin (AnnTip blk)
forall t. t -> WithOrigin t
NotOrigin (AnnTip blk -> WithOrigin (AnnTip blk))
-> (HeaderWithTime blk -> AnnTip blk)
-> HeaderWithTime blk
-> WithOrigin (AnnTip blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header blk -> AnnTip blk
forall blk.
(HasHeader (Header blk), HasAnnTip blk) =>
Header blk -> AnnTip blk
getAnnTip (Header blk -> AnnTip blk)
-> (HeaderWithTime blk -> Header blk)
-> HeaderWithTime blk
-> AnnTip blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderWithTime blk -> Header blk
forall blk. HeaderWithTime blk -> Header blk
hwtHeader (HeaderWithTime blk -> WithOrigin (AnnTip blk))
-> [HeaderWithTime blk] -> [WithOrigin (AnnTip blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> [HeaderWithTime blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
theirFrag

          fragmentAnchorPoint :: Point blk
fragmentAnchorPoint = Point (HeaderWithTime blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (HeaderWithTime blk) -> Point blk)
-> Point (HeaderWithTime blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> Point (HeaderWithTime blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
theirFrag
          historyAnchorPoint :: Point blk
historyAnchorPoint  =
              WithOrigin (RealPoint blk) -> Point blk
forall blk. WithOrigin (RealPoint blk) -> Point blk
withOriginRealPointToPoint
            (WithOrigin (RealPoint blk) -> Point blk)
-> WithOrigin (RealPoint blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnnTip blk -> RealPoint blk
forall blk. HasAnnTip blk => AnnTip blk -> RealPoint blk
annTipRealPoint (AnnTip blk -> RealPoint blk)
-> WithOrigin (AnnTip blk) -> WithOrigin (RealPoint blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderState blk -> WithOrigin (AnnTip blk)
forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
headerStateTip (HeaderStateWithTime blk -> HeaderState blk
forall blk. HeaderStateWithTime blk -> HeaderState blk
hswtHeaderState (HeaderStateWithTime blk -> HeaderState blk)
-> HeaderStateWithTime blk -> HeaderState blk
forall a b. (a -> b) -> a -> b
$ AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> HeaderStateWithTime blk
forall v a b. AnchoredSeq v a b -> a
AS.anchor AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
snapshots)
    ,    [WithOrigin (AnnTip blk)]
historyTips        [WithOrigin (AnnTip blk)] -> [WithOrigin (AnnTip blk)] -> Bool
forall a. Eq a => a -> a -> Bool
/= [WithOrigin (AnnTip blk)]
fragmentTips
      Bool -> Bool -> Bool
||
         Point blk
historyAnchorPoint Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
/= Point blk
fragmentAnchorPoint
    = String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ Context -> String
unwords
      [ String
"The tips in theirHeaderStateHistory"
      , String
"didn't match the headers in theirFrag:"
      , [WithOrigin (AnnTip blk)] -> String
forall a. Show a => a -> String
show [WithOrigin (AnnTip blk)]
historyTips
      , String
"vs"
      , [WithOrigin (AnnTip blk)] -> String
forall a. Show a => a -> String
show [WithOrigin (AnnTip blk)]
fragmentTips
      , String
"with anchors"
      , Point blk -> String
forall a. Show a => a -> String
show Point blk
historyAnchorPoint
      , String
"vs"
      , Point blk -> String
forall a. Show a => a -> String
show Point blk
fragmentAnchorPoint
      ]

    -- 'ourFrag' invariants
    | let nbHeaders :: Int
nbHeaders      = AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
ourFrag
          ourAnchorPoint :: Point (Header blk)
ourAnchorPoint = AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Point (Header blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
ourFrag
    , Int
nbHeaders Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k)
    , Point (Header blk)
ourAnchorPoint Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
/= Point (Header blk)
forall {k} (block :: k). Point block
GenesisPoint
    = String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ Context -> String
unwords
      [ String
"ourFrag contains fewer than k headers and not close to genesis:"
      , Int -> String
forall a. Show a => a -> String
show Int
nbHeaders
      , String
"vs"
      , NonZero Word64 -> String
forall a. Show a => a -> String
show NonZero Word64
k
      , String
"with anchor"
      , Point (Header blk) -> String
forall a. Show a => a -> String
show Point (Header blk)
ourAnchorPoint
      ]

    | let ourFragAnchor :: Point (Header blk)
ourFragAnchor   = AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Point (Header blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
ourFrag
          theirFragAnchor :: Point (HeaderWithTime blk)
theirFragAnchor = AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> Point (HeaderWithTime blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
theirFrag
    , Point (Header blk)
ourFragAnchor Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
/= Point (HeaderWithTime blk) -> Point (Header blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point (HeaderWithTime blk)
theirFragAnchor
    = String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ Context -> String
unwords
      [ String
"ourFrag and theirFrag have different anchor points:"
      , Point (Header blk) -> String
forall a. Show a => a -> String
show Point (Header blk)
ourFragAnchor
      , String
"vs"
      , Point (HeaderWithTime blk) -> String
forall a. Show a => a -> String
show Point (HeaderWithTime blk)
theirFragAnchor
      ]

    -- 'mostRecentIntersection' invariant
    | let actualMostRecentIntersection :: Maybe (Point blk)
actualMostRecentIntersection =
              Point (HeaderWithTime blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (HeaderWithTime blk) -> Point blk)
-> Maybe (Point (HeaderWithTime blk)) -> Maybe (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
-> Maybe (Point (HeaderWithTime blk))
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2 -> Maybe (Point block1)
AF.intersectionPoint AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
theirFrag AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
ourFrag
    , Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just Point blk
mostRecentIntersection Maybe (Point blk) -> Maybe (Point blk) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (Point blk)
actualMostRecentIntersection
    = String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ Context -> String
unwords
      [ String
"mostRecentIntersection not the most recent intersection"
      , String
"of theirFrag and ourFrag:"
      , Point blk -> String
forall a. Show a => a -> String
show Point blk
mostRecentIntersection
      , String
"vs"
      , Maybe (Point blk) -> String
forall a. Show a => a -> String
show Maybe (Point blk)
actualMostRecentIntersection
      ]

    | Bool
otherwise
    = () -> Either String ()
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    SecurityParam NonZero Word64
k = ConsensusConfig (BlockProtocol blk) -> SecurityParam
forall p. ConsensusProtocol p => ConsensusConfig p -> SecurityParam
protocolSecurityParam ConsensusConfig (BlockProtocol blk)
cfg

    KnownIntersectionState {
        Point blk
mostRecentIntersection :: forall blk. KnownIntersectionState blk -> Point blk
mostRecentIntersection :: Point blk
mostRecentIntersection
      , AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
ourFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (Header blk)
ourFrag :: AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
ourFrag
      , AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
theirFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (HeaderWithTime blk)
theirFrag :: AnchoredSeq
  (WithOrigin SlotNo)
  (Anchor (HeaderWithTime blk))
  (HeaderWithTime blk)
theirFrag
      , HeaderStateHistory blk
theirHeaderStateHistory :: forall blk. KnownIntersectionState blk -> HeaderStateHistory blk
theirHeaderStateHistory :: HeaderStateHistory blk
theirHeaderStateHistory
      } = KnownIntersectionState blk
kis

assertKnownIntersectionInvariants ::
    ( HasHeader blk
    , HasHeader (Header blk)
    , HasAnnTip blk
    , ConsensusProtocol (BlockProtocol blk)
    , HasCallStack
    )
 => ConsensusConfig (BlockProtocol blk)
 -> KnownIntersectionState blk
 -> KnownIntersectionState blk
assertKnownIntersectionInvariants :: forall blk.
(HasHeader blk, HasHeader (Header blk), HasAnnTip blk,
 ConsensusProtocol (BlockProtocol blk), HasCallStack) =>
ConsensusConfig (BlockProtocol blk)
-> KnownIntersectionState blk -> KnownIntersectionState blk
assertKnownIntersectionInvariants ConsensusConfig (BlockProtocol blk)
cfg KnownIntersectionState blk
kis =
    Either String ()
-> KnownIntersectionState blk -> KnownIntersectionState blk
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (ConsensusConfig (BlockProtocol blk)
-> KnownIntersectionState blk -> Either String ()
forall blk.
(HasHeader blk, HasHeader (Header blk), HasAnnTip blk,
 ConsensusProtocol (BlockProtocol blk)) =>
ConsensusConfig (BlockProtocol blk)
-> KnownIntersectionState blk -> Either String ()
checkKnownIntersectionInvariants ConsensusConfig (BlockProtocol blk)
cfg KnownIntersectionState blk
kis) KnownIntersectionState blk
kis

{-------------------------------------------------------------------------------
  The ChainSync client definition
-------------------------------------------------------------------------------}

-- | Arguments determined by configuration
--
-- These are available before the diffusion layer is online.
data ConfigEnv m blk = ConfigEnv {
    forall (m :: * -> *) blk. ConfigEnv m blk -> MkPipelineDecision
mkPipelineDecision0     :: MkPipelineDecision
    -- ^ The pipelining decider to use after 'MsgFoundIntersect' arrives
  , forall (m :: * -> *) blk.
ConfigEnv m blk -> Tracer m (TraceChainSyncClientEvent blk)
tracer                  :: Tracer m (TraceChainSyncClientEvent blk)
  , forall (m :: * -> *) blk. ConfigEnv m blk -> TopLevelConfig blk
cfg                     :: TopLevelConfig blk
  , forall (m :: * -> *) blk.
ConfigEnv m blk -> SomeHeaderInFutureCheck m blk
someHeaderInFutureCheck :: InFutureCheck.SomeHeaderInFutureCheck m blk
  , forall (m :: * -> *) blk. ConfigEnv m blk -> HistoricityCheck m blk
historicityCheck        :: HistoricityCheck m blk
  , forall (m :: * -> *) blk. ConfigEnv m blk -> ChainDbView m blk
chainDbView             :: ChainDbView m blk
  , forall (m :: * -> *) blk.
ConfigEnv m blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport
                            :: DiffusionPipeliningSupport
  }

-- | Arguments determined dynamically
--
-- These are available only after the diffusion layer is online and/or on per
-- client basis.
data DynamicEnv m blk = DynamicEnv {
    forall (m :: * -> *) blk. DynamicEnv m blk -> NodeToNodeVersion
version             :: NodeToNodeVersion
  , forall (m :: * -> *) blk. DynamicEnv m blk -> ControlMessageSTM m
controlMessageSTM   :: ControlMessageSTM m
  , forall (m :: * -> *) blk. DynamicEnv m blk -> HeaderMetricsTracer m
headerMetricsTracer :: HeaderMetricsTracer m
  , forall (m :: * -> *) blk.
DynamicEnv m blk
-> AnchoredFragment (HeaderWithTime blk) -> STM m ()
setCandidate        :: AnchoredFragment (HeaderWithTime blk) -> STM m ()
  , forall (m :: * -> *) blk.
DynamicEnv m blk -> WithOrigin SlotNo -> STM m ()
setLatestSlot       :: WithOrigin SlotNo -> STM m ()
  , forall (m :: * -> *) blk. DynamicEnv m blk -> Idling m
idling              :: Idling m
  , forall (m :: * -> *) blk. DynamicEnv m blk -> LoPBucket m
loPBucket           :: LoPBucket m
  , forall (m :: * -> *) blk. DynamicEnv m blk -> Jumping m blk
jumping             :: Jumping.Jumping m blk
  }

-- | General values collectively needed by the top-level entry points
data InternalEnv m blk arrival judgment = InternalEnv {
    forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> forall s (n :: N).
   NoThunks s =>
   Nat n
   -> Stateful m blk s (ClientPipelinedStIdle 'Z)
   -> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe ::
      forall s n.
         NoThunks s
      => Nat n
      -> Stateful m blk s (ClientPipelinedStIdle 'Z)
      -> Stateful m blk s (ClientPipelinedStIdle n)
    -- ^ "Drain the pipe": collect and discard all in-flight responses and
    -- finally execute the given action.
  ,
    forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> forall (m' :: * -> *) a.
   MonadThrow m' =>
   ChainSyncClientException -> m' a
disconnect ::
      forall m' a.
         MonadThrow m'
      => ChainSyncClientException
      -> m' a
    -- ^ Disconnect from the upstream node by throwing the given exception.
    -- The cleanup is handled in 'bracketChainSyncClient'.
  ,
    forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck ::
        InFutureCheck.HeaderInFutureCheck m blk arrival judgment
  ,
    forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> KnownIntersectionState blk
-> STM m (UpdatedIntersectionState blk ())
intersectsWithCurrentChain ::
        KnownIntersectionState blk
     -> STM m (UpdatedIntersectionState blk ())
    -- ^ A combinator necessary whenever relying on a
    -- 'KnownIntersectionState', since it's always possible that that
    -- intersection will go stale.
    --
    -- Look at the current chain fragment that may have been updated in the
    -- background. Check whether the candidate fragment still intersects with
    -- it. If so, update the 'KnownIntersectionState' and trim the candidate
    -- fragment to the new current chain fragment's anchor point. If not,
    -- return 'Nothing'.
    --
    -- INVARIANT: This a read-only STM transaction.
  ,
    forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
terminate ::
        ChainSyncClientResult
     -> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
    -- ^ Gracefully terminate the connection with the upstream node with the
    -- given result.
  ,
    forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> forall (n :: N).
   Nat n
   -> ChainSyncClientResult
   -> m (Consensus (ClientPipelinedStIdle n) blk m)
terminateAfterDrain ::
      forall n.
         Nat n
      -> ChainSyncClientResult
      -> m (Consensus (ClientPipelinedStIdle n) blk m)
    -- ^ Same as 'terminate', but first 'drainThePipe'.
  ,
    forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment -> forall a. m a -> m a
traceException :: forall a. m a -> m a
    -- ^ Trace any 'ChainSyncClientException' if thrown.
  }

-- | Chain sync client
--
-- This never terminates. In case of a failure, a 'ChainSyncClientException'
-- is thrown. The network layer classifies exception such that the
-- corresponding peer will never be chosen again.
chainSyncClient :: forall m blk.
     ( IOLike m
     , LedgerSupportsProtocol blk
     )
  => ConfigEnv m blk
  -> DynamicEnv m blk
  -> Consensus ChainSyncClientPipelined blk m
chainSyncClient :: forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk -> Consensus ChainSyncClientPipelined blk m
chainSyncClient ConfigEnv m blk
cfgEnv DynamicEnv m blk
dynEnv =
    case ConfigEnv m blk -> SomeHeaderInFutureCheck m blk
forall (m :: * -> *) blk.
ConfigEnv m blk -> SomeHeaderInFutureCheck m blk
someHeaderInFutureCheck ConfigEnv m blk
cfgEnv of
        InFutureCheck.SomeHeaderInFutureCheck HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck ->
            m (ClientPipelinedStIdle
     'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
-> Consensus ChainSyncClientPipelined blk m
forall header point tip (m :: * -> *) a.
m (ClientPipelinedStIdle 'Z header point tip m a)
-> ChainSyncClientPipelined header point tip m a
ChainSyncClientPipelined
          (m (ClientPipelinedStIdle
      'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
 -> Consensus ChainSyncClientPipelined blk m)
-> m (ClientPipelinedStIdle
        'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
-> Consensus ChainSyncClientPipelined blk m
forall a b. (a -> b) -> a -> b
$ ()
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
-> m (ClientPipelinedStIdle
        'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState ()
          (Stateful m blk () (ClientPipelinedStIdle 'Z)
 -> m (ClientPipelinedStIdle
         'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
-> m (ClientPipelinedStIdle
        'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall a b. (a -> b) -> a -> b
$ -- Start ChainSync by looking for an intersection between our
            -- current chain fragment and their chain.
            ConfigEnv m blk
-> DynamicEnv m blk
-> InternalEnv m blk arrival judgment
-> BlockNo
-> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
forall (m :: * -> *) blk arrival judgment.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk
-> InternalEnv m blk arrival judgment
-> BlockNo
-> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
findIntersectionTop
                ConfigEnv m blk
cfgEnv
                DynamicEnv m blk
dynEnv
                (HeaderInFutureCheck m blk arrival judgment
-> InternalEnv m blk arrival judgment
forall arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> InternalEnv m blk arrival judgment
mkIntEnv HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck)
                (Word64 -> BlockNo
BlockNo Word64
0)
                (Point blk
-> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult
forall blk.
BlockSupportsProtocol blk =>
Point blk
-> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult
ForkTooDeep Point blk
forall {k} (block :: k). Point block
GenesisPoint)
  where
    ConfigEnv {
        TopLevelConfig blk
cfg :: forall (m :: * -> *) blk. ConfigEnv m blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
      , ChainDbView m blk
chainDbView :: forall (m :: * -> *) blk. ConfigEnv m blk -> ChainDbView m blk
chainDbView :: ChainDbView m blk
chainDbView
      , Tracer m (TraceChainSyncClientEvent blk)
tracer :: forall (m :: * -> *) blk.
ConfigEnv m blk -> Tracer m (TraceChainSyncClientEvent blk)
tracer :: Tracer m (TraceChainSyncClientEvent blk)
tracer
      } = ConfigEnv m blk
cfgEnv

    ChainDbView {
        STM m (AnchoredFragment (Header blk))
getCurrentChain :: forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (AnchoredFragment (Header blk))
getCurrentChain :: STM m (AnchoredFragment (Header blk))
getCurrentChain
      } = ChainDbView m blk
chainDbView

    DynamicEnv {
        Idling m
idling :: forall (m :: * -> *) blk. DynamicEnv m blk -> Idling m
idling :: Idling m
idling
      } = DynamicEnv m blk
dynEnv

    mkIntEnv ::
        InFutureCheck.HeaderInFutureCheck m blk arrival judgment
     -> InternalEnv                       m blk arrival judgment
    mkIntEnv :: forall arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> InternalEnv m blk arrival judgment
mkIntEnv HeaderInFutureCheck m blk arrival judgment
hifc = InternalEnv {
        Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
forall s (n :: N).
NoThunks s =>
Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe :: forall s (n :: N).
NoThunks s =>
Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe :: forall s (n :: N).
NoThunks s =>
Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe
      ,
        disconnect :: forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect = ChainSyncClientException -> m' a
forall e a. Exception e => e -> m' a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
throwIO
      ,
        headerInFutureCheck :: HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck = HeaderInFutureCheck m blk arrival judgment
hifc
      ,
        KnownIntersectionState blk
-> STM m (UpdatedIntersectionState blk ())
intersectsWithCurrentChain :: KnownIntersectionState blk
-> STM m (UpdatedIntersectionState blk ())
intersectsWithCurrentChain :: KnownIntersectionState blk
-> STM m (UpdatedIntersectionState blk ())
intersectsWithCurrentChain
      ,
        ChainSyncClientResult
-> m (ClientPipelinedStIdle
        'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
terminate :: ChainSyncClientResult
-> m (ClientPipelinedStIdle
        'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
terminate :: ChainSyncClientResult
-> m (ClientPipelinedStIdle
        'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
terminate
      ,
        terminateAfterDrain :: forall (n :: N).
Nat n
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle n) blk m)
terminateAfterDrain = \Nat n
n ChainSyncClientResult
result ->
            ()
-> Stateful m blk () (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState ()
          (Stateful m blk () (ClientPipelinedStIdle n)
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful m blk () (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$ Nat n
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
-> Stateful m blk () (ClientPipelinedStIdle n)
forall s (n :: N).
NoThunks s =>
Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe Nat n
n
          (Stateful m blk () (ClientPipelinedStIdle 'Z)
 -> Stateful m blk () (ClientPipelinedStIdle n))
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
-> Stateful m blk () (ClientPipelinedStIdle n)
forall a b. (a -> b) -> a -> b
$ (()
 -> m (ClientPipelinedStIdle
         'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
forall (m :: * -> *) blk s
       (st :: * -> * -> * -> (* -> *) -> * -> *).
(s -> m (Consensus st blk m)) -> Stateful m blk s st
Stateful ((()
  -> m (ClientPipelinedStIdle
          'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
 -> Stateful m blk () (ClientPipelinedStIdle 'Z))
-> (()
    -> m (ClientPipelinedStIdle
            'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
forall a b. (a -> b) -> a -> b
$ \() -> ChainSyncClientResult
-> m (ClientPipelinedStIdle
        'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
terminate ChainSyncClientResult
result
      ,
        traceException :: forall a. m a -> m a
traceException = \m a
m -> do
            m a
m m a -> (ChainSyncClientException -> m a) -> m a
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ChainSyncClientException
e :: ChainSyncClientException) -> do
                Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ ChainSyncClientException -> TraceChainSyncClientEvent blk
forall blk.
ChainSyncClientException -> TraceChainSyncClientEvent blk
TraceException ChainSyncClientException
e
                ChainSyncClientException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ChainSyncClientException
e
      }

    drainThePipe ::
      forall s n.
         NoThunks s
      => Nat n
      -> Stateful m blk s (ClientPipelinedStIdle 'Z)
      -> Stateful m blk s (ClientPipelinedStIdle n)
    drainThePipe :: forall s (n :: N).
NoThunks s =>
Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe Nat n
n0 Stateful m blk s (ClientPipelinedStIdle 'Z)
m =
      let go ::
            forall n'.
               Nat n'
            -> s
            -> m (Consensus (ClientPipelinedStIdle n') blk m)
          go :: forall (n' :: N).
Nat n' -> s -> m (Consensus (ClientPipelinedStIdle n') blk m)
go Nat n'
n s
s = do
            Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Nat n' -> TraceChainSyncClientEvent blk
forall blk (n :: N). Nat n -> TraceChainSyncClientEvent blk
TraceDrainingThePipe Nat n'
n
            case Nat n'
n of
              Nat n'
Zero    -> s
-> Stateful m blk s (ClientPipelinedStIdle n')
-> m (Consensus (ClientPipelinedStIdle n') blk m)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState s
s Stateful m blk s (ClientPipelinedStIdle n')
Stateful m blk s (ClientPipelinedStIdle 'Z)
m
              Succ Nat n
n' -> Consensus (ClientPipelinedStIdle n') blk m
-> m (Consensus (ClientPipelinedStIdle n') blk m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Consensus (ClientPipelinedStIdle n') blk m
 -> m (Consensus (ClientPipelinedStIdle n') blk m))
-> Consensus (ClientPipelinedStIdle n') blk m
-> m (Consensus (ClientPipelinedStIdle n') blk m)
forall a b. (a -> b) -> a -> b
$ Maybe
  (m (ClientPipelinedStIdle
        ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
-> ClientStNext
     n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CollectResponse Maybe
  (m (ClientPipelinedStIdle
        ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
forall a. Maybe a
Nothing (ClientStNext
   n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
 -> ClientPipelinedStIdle
      ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
-> ClientStNext
     n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall a b. (a -> b) -> a -> b
$ ClientStNext {
                  recvMsgRollForward :: Header blk
-> Tip blk
-> m (ClientPipelinedStIdle
        n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
recvMsgRollForward  = \Header blk
_hdr Tip blk
_tip -> Nat n
-> s
-> m (ClientPipelinedStIdle
        n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall (n' :: N).
Nat n' -> s -> m (Consensus (ClientPipelinedStIdle n') blk m)
go Nat n
n' s
s
                , recvMsgRollBackward :: Point blk
-> Tip blk
-> m (ClientPipelinedStIdle
        n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
recvMsgRollBackward = \Point blk
_pt  Tip blk
_tip -> Nat n
-> s
-> m (ClientPipelinedStIdle
        n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall (n' :: N).
Nat n' -> s -> m (Consensus (ClientPipelinedStIdle n') blk m)
go Nat n
n' s
s
                }
      in (s -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful m blk s (ClientPipelinedStIdle n)
forall (m :: * -> *) blk s
       (st :: * -> * -> * -> (* -> *) -> * -> *).
(s -> m (Consensus st blk m)) -> Stateful m blk s st
Stateful ((s -> m (Consensus (ClientPipelinedStIdle n) blk m))
 -> Stateful m blk s (ClientPipelinedStIdle n))
-> (s -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful m blk s (ClientPipelinedStIdle n)
forall a b. (a -> b) -> a -> b
$ \s
s -> Idling m -> m ()
forall (m :: * -> *). Idling m -> m ()
idlingStop Idling m
idling m ()
-> m (Consensus (ClientPipelinedStIdle n) blk m)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Nat n -> s -> m (Consensus (ClientPipelinedStIdle n) blk m)
forall (n' :: N).
Nat n' -> s -> m (Consensus (ClientPipelinedStIdle n') blk m)
go Nat n
n0 s
s

    terminate ::
        ChainSyncClientResult
     -> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
    terminate :: ChainSyncClientResult
-> m (ClientPipelinedStIdle
        'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
terminate ChainSyncClientResult
res = do
        Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (ChainSyncClientResult -> TraceChainSyncClientEvent blk
forall blk. ChainSyncClientResult -> TraceChainSyncClientEvent blk
TraceTermination ChainSyncClientResult
res)
        ClientPipelinedStIdle
  'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> m (ClientPipelinedStIdle
        'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainSyncClientResult
-> ClientPipelinedStIdle
     'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
SendMsgDone ChainSyncClientResult
res)

    intersectsWithCurrentChain ::
        KnownIntersectionState blk
     -> STM m (UpdatedIntersectionState blk ())
    intersectsWithCurrentChain :: KnownIntersectionState blk
-> STM m (UpdatedIntersectionState blk ())
intersectsWithCurrentChain KnownIntersectionState blk
kis = do
        let KnownIntersectionState {
                AnchoredFragment (Header blk)
ourFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (Header blk)
ourFrag :: AnchoredFragment (Header blk)
ourFrag
              , AnchoredFragment (HeaderWithTime blk)
theirFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (HeaderWithTime blk)
theirFrag :: AnchoredFragment (HeaderWithTime blk)
theirFrag
              , HeaderStateHistory blk
theirHeaderStateHistory :: forall blk. KnownIntersectionState blk -> HeaderStateHistory blk
theirHeaderStateHistory :: HeaderStateHistory blk
theirHeaderStateHistory
              , BlockNo
kBestBlockNo :: forall blk. KnownIntersectionState blk -> BlockNo
kBestBlockNo :: BlockNo
kBestBlockNo
              } = KnownIntersectionState blk
kis
        ourFrag' <- STM m (AnchoredFragment (Header blk))
getCurrentChain

        -- Our current chain didn't change, and changes to their chain that
        -- might affect the intersection point are handled elsewhere
        -- ('rollBackward'), so we have nothing to do.
        let noChange = AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
ourFrag Point (Header blk) -> Point (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
ourFrag'

        return $ if noChange then StillIntersects () kis else do
            case AF.intersectionPoint ourFrag' theirFrag of
                Just Point (Header blk)
intersection
                  | Just (AnchoredFragment (HeaderWithTime blk)
_, AnchoredFragment (HeaderWithTime blk)
trimmedCandidate) <-
                      AnchoredFragment (HeaderWithTime blk)
-> Point (Header blk)
-> Maybe
     (AnchoredFragment (HeaderWithTime blk),
      AnchoredFragment (HeaderWithTime blk))
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
AF.splitAfterPoint AnchoredFragment (HeaderWithTime blk)
theirFrag (AnchoredFragment (Header blk) -> Point (Header blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment (Header blk)
ourFrag')
                  ->
                    -- Even though our current chain changed it still
                    -- intersects with candidate fragment, so update the
                    -- 'ourFrag' field and trim the candidate fragment to the
                    -- same anchor point.
                    --
                    -- Note that this is the only place we need to trim.
                    -- Headers on their chain can only become unnecessary
                    -- (eligible for trimming) in two ways: 1. we adopted them,
                    -- i.e., our chain changed (handled in this function); 2.
                    -- we will /never/ adopt them, which is handled in the "no
                    -- more intersection case".
                    () -> KnownIntersectionState blk -> UpdatedIntersectionState blk ()
forall blk a.
a -> KnownIntersectionState blk -> UpdatedIntersectionState blk a
StillIntersects ()
                  (KnownIntersectionState blk -> UpdatedIntersectionState blk ())
-> KnownIntersectionState blk -> UpdatedIntersectionState blk ()
forall a b. (a -> b) -> a -> b
$ ConsensusConfig (BlockProtocol blk)
-> KnownIntersectionState blk -> KnownIntersectionState blk
forall blk.
(HasHeader blk, HasHeader (Header blk), HasAnnTip blk,
 ConsensusProtocol (BlockProtocol blk), HasCallStack) =>
ConsensusConfig (BlockProtocol blk)
-> KnownIntersectionState blk -> KnownIntersectionState blk
assertKnownIntersectionInvariants (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
                  (KnownIntersectionState blk -> KnownIntersectionState blk)
-> KnownIntersectionState blk -> KnownIntersectionState blk
forall a b. (a -> b) -> a -> b
$ KnownIntersectionState {
                        mostRecentIntersection :: Point blk
mostRecentIntersection  = Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point (Header blk)
intersection
                      , ourFrag :: AnchoredFragment (Header blk)
ourFrag                 = AnchoredFragment (Header blk)
ourFrag'
                      , theirFrag :: AnchoredFragment (HeaderWithTime blk)
theirFrag               = AnchoredFragment (HeaderWithTime blk)
trimmedCandidate
                      , theirHeaderStateHistory :: HeaderStateHistory blk
theirHeaderStateHistory =
                            -- We trim the 'HeaderStateHistory' to the same
                            -- size as our fragment so they keep in sync.
                            Int -> HeaderStateHistory blk -> HeaderStateHistory blk
forall blk. Int -> HeaderStateHistory blk -> HeaderStateHistory blk
HeaderStateHistory.trim
                                (AnchoredFragment (HeaderWithTime blk) -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment (HeaderWithTime blk)
trimmedCandidate)
                                HeaderStateHistory blk
theirHeaderStateHistory
                      , BlockNo
kBestBlockNo :: BlockNo
kBestBlockNo :: BlockNo
kBestBlockNo
                      }

                Maybe (Point (Header blk))
_ -> UpdatedIntersectionState blk ()
forall blk a. UpdatedIntersectionState blk a
NoLongerIntersects

{-------------------------------------------------------------------------------
  (Re-)Establishing a common intersection
-------------------------------------------------------------------------------}

findIntersectionTop ::
  forall m blk arrival judgment.
     ( IOLike m
     , LedgerSupportsProtocol blk
     )
  => ConfigEnv m blk
  -> DynamicEnv m blk
  -> InternalEnv m blk arrival judgment
  -> BlockNo
     -- ^ Peer's best block; needed to build an 'UnknownIntersectionState'.
  -> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
     -- ^ Exception to throw when no intersection is found.
  -> Stateful m blk () (ClientPipelinedStIdle 'Z)
findIntersectionTop :: forall (m :: * -> *) blk arrival judgment.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk
-> InternalEnv m blk arrival judgment
-> BlockNo
-> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
findIntersectionTop ConfigEnv m blk
cfgEnv DynamicEnv m blk
dynEnv InternalEnv m blk arrival judgment
intEnv =
    BlockNo
-> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
findIntersection
  where
    ConfigEnv {
        Tracer m (TraceChainSyncClientEvent blk)
tracer :: forall (m :: * -> *) blk.
ConfigEnv m blk -> Tracer m (TraceChainSyncClientEvent blk)
tracer :: Tracer m (TraceChainSyncClientEvent blk)
tracer
      , TopLevelConfig blk
cfg :: forall (m :: * -> *) blk. ConfigEnv m blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
      , ChainDbView m blk
chainDbView :: forall (m :: * -> *) blk. ConfigEnv m blk -> ChainDbView m blk
chainDbView :: ChainDbView m blk
chainDbView
      } = ConfigEnv m blk
cfgEnv

    ChainDbView {
        STM m (AnchoredFragment (Header blk))
getCurrentChain :: forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (AnchoredFragment (Header blk))
getCurrentChain :: STM m (AnchoredFragment (Header blk))
getCurrentChain
      , STM m (HeaderStateHistory blk)
getHeaderStateHistory :: forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (HeaderStateHistory blk)
getHeaderStateHistory :: STM m (HeaderStateHistory blk)
getHeaderStateHistory
      } = ChainDbView m blk
chainDbView

    DynamicEnv {
        AnchoredFragment (HeaderWithTime blk) -> STM m ()
setCandidate :: forall (m :: * -> *) blk.
DynamicEnv m blk
-> AnchoredFragment (HeaderWithTime blk) -> STM m ()
setCandidate :: AnchoredFragment (HeaderWithTime blk) -> STM m ()
setCandidate
      , Jumping m blk
jumping :: forall (m :: * -> *) blk. DynamicEnv m blk -> Jumping m blk
jumping :: Jumping m blk
jumping
      } = DynamicEnv m blk
dynEnv

    InternalEnv {
        forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> forall (m' :: * -> *) a.
   MonadThrow m' =>
   ChainSyncClientException -> m' a
disconnect :: forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect
      , ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
terminate :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
terminate :: ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
terminate
      , forall a. m a -> m a
traceException :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment -> forall a. m a -> m a
traceException :: forall a. m a -> m a
traceException
      } = InternalEnv m blk arrival judgment
intEnv

    -- Try to find an intersection by sending points of our current chain to
    -- the server, if any of them intersect with their chain, roll back our
    -- chain to that point and start synching using that fragment. If none
    -- intersect, disconnect by throwing the exception obtained by calling the
    -- passed function.
    findIntersection ::
        BlockNo
        -- ^ Peer's best block; needed to build an 'UnknownIntersectionState'.
     -> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
        -- ^ Exception to throw when no intersection is found.
     -> Stateful m blk () (ClientPipelinedStIdle 'Z)
    findIntersection :: BlockNo
-> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
findIntersection BlockNo
uBestBlockNo Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult
mkResult = (() -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
forall (m :: * -> *) blk s
       (st :: * -> * -> * -> (* -> *) -> * -> *).
(s -> m (Consensus st blk m)) -> Stateful m blk s st
Stateful ((() -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
 -> Stateful m blk () (ClientPipelinedStIdle 'Z))
-> (() -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
forall a b. (a -> b) -> a -> b
$ \() -> do
        (ourFrag, ourHeaderStateHistory) <- STM m (AnchoredFragment (Header blk), HeaderStateHistory blk)
-> m (AnchoredFragment (Header blk), HeaderStateHistory blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (AnchoredFragment (Header blk), HeaderStateHistory blk)
 -> m (AnchoredFragment (Header blk), HeaderStateHistory blk))
-> STM m (AnchoredFragment (Header blk), HeaderStateHistory blk)
-> m (AnchoredFragment (Header blk), HeaderStateHistory blk)
forall a b. (a -> b) -> a -> b
$ (,)
            (AnchoredFragment (Header blk)
 -> HeaderStateHistory blk
 -> (AnchoredFragment (Header blk), HeaderStateHistory blk))
-> STM m (AnchoredFragment (Header blk))
-> STM
     m
     (HeaderStateHistory blk
      -> (AnchoredFragment (Header blk), HeaderStateHistory blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (AnchoredFragment (Header blk))
getCurrentChain
            STM
  m
  (HeaderStateHistory blk
   -> (AnchoredFragment (Header blk), HeaderStateHistory blk))
-> STM m (HeaderStateHistory blk)
-> STM m (AnchoredFragment (Header blk), HeaderStateHistory blk)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM m (HeaderStateHistory blk)
getHeaderStateHistory
        -- This means that if an intersection is found for one of these points,
        -- it was an intersection within the last @k@ blocks of our current
        -- chain. If not, we could never switch to this candidate chain anyway.
        let maxOffset = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredFragment (Header blk) -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment (Header blk)
ourFrag)
            k         = ConsensusConfig (BlockProtocol blk) -> SecurityParam
forall p. ConsensusProtocol p => ConsensusConfig p -> SecurityParam
protocolSecurityParam (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
            offsets   = SecurityParam -> Word64 -> [Word64]
mkOffsets SecurityParam
k Word64
maxOffset
            points    =
                (Point (Header blk) -> Point blk)
-> [Point (Header blk)] -> [Point blk]
forall a b. (a -> b) -> [a] -> [b]
map Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint
              ([Point (Header blk)] -> [Point blk])
-> [Point (Header blk)] -> [Point blk]
forall a b. (a -> b) -> a -> b
$ [Int] -> AnchoredFragment (Header blk) -> [Point (Header blk)]
forall block.
HasHeader block =>
[Int] -> AnchoredFragment block -> [Point block]
AF.selectPoints ((Word64 -> Int) -> [Word64] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word64]
offsets) AnchoredFragment (Header blk)
ourFrag

            !uis = UnknownIntersectionState {
                ourFrag :: AnchoredFragment (Header blk)
ourFrag               = AnchoredFragment (Header blk)
ourFrag
              , ourHeaderStateHistory :: HeaderStateHistory blk
ourHeaderStateHistory = HeaderStateHistory blk
ourHeaderStateHistory
              , BlockNo
uBestBlockNo :: BlockNo
uBestBlockNo :: BlockNo
uBestBlockNo
              }

        return
          $ SendMsgFindIntersect points
          $ ClientPipelinedStIntersect {
                recvMsgIntersectFound    = \Point blk
i Tip blk
theirTip' ->
                    UnknownIntersectionState blk
-> Stateful
     m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z)
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState UnknownIntersectionState blk
uis
                  (Stateful
   m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z)
 -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> Stateful
     m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z)
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall a b. (a -> b) -> a -> b
$ Point blk
-> Their (Tip blk)
-> Stateful
     m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z)
intersectFound (Point blk -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
i) (Tip blk -> Their (Tip blk)
forall a. a -> Their a
Their Tip blk
theirTip')
              ,
                recvMsgIntersectNotFound = \Tip blk
theirTip' ->
                    ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
terminate
                  (ChainSyncClientResult
 -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall a b. (a -> b) -> a -> b
$ Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult
mkResult (AnchoredFragment (Header blk) -> Our (Tip blk)
forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk) -> Our (Tip blk)
ourTipFromChain AnchoredFragment (Header blk)
ourFrag) (Tip blk -> Their (Tip blk)
forall a. a -> Their a
Their Tip blk
theirTip')
              }

    -- One of the points we sent intersected our chain. This intersection point
    -- will become the new tip of the candidate fragment.
    intersectFound ::
        Point blk  -- ^ Intersection
     -> Their (Tip blk)
     -> Stateful m blk
            (UnknownIntersectionState blk)
            (ClientPipelinedStIdle 'Z)
    intersectFound :: Point blk
-> Their (Tip blk)
-> Stateful
     m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z)
intersectFound Point blk
intersection Their (Tip blk)
theirTip = (UnknownIntersectionState blk
 -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> Stateful
     m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z)
forall (m :: * -> *) blk s
       (st :: * -> * -> * -> (* -> *) -> * -> *).
(s -> m (Consensus st blk m)) -> Stateful m blk s st
Stateful ((UnknownIntersectionState blk
  -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
 -> Stateful
      m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z))
-> (UnknownIntersectionState blk
    -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> Stateful
     m blk (UnknownIntersectionState blk) (ClientPipelinedStIdle 'Z)
forall a b. (a -> b) -> a -> b
$ \UnknownIntersectionState blk
uis -> do
        let UnknownIntersectionState {
                AnchoredFragment (Header blk)
ourFrag :: forall blk.
UnknownIntersectionState blk -> AnchoredFragment (Header blk)
ourFrag :: AnchoredFragment (Header blk)
ourFrag
              , HeaderStateHistory blk
ourHeaderStateHistory :: forall blk. UnknownIntersectionState blk -> HeaderStateHistory blk
ourHeaderStateHistory :: HeaderStateHistory blk
ourHeaderStateHistory
              , BlockNo
uBestBlockNo :: forall blk. UnknownIntersectionState blk -> BlockNo
uBestBlockNo :: BlockNo
uBestBlockNo
              } = UnknownIntersectionState blk
uis
        Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$
            Point blk
-> Our (Tip blk)
-> Their (Tip blk)
-> TraceChainSyncClientEvent blk
forall blk.
Point blk
-> Our (Tip blk)
-> Their (Tip blk)
-> TraceChainSyncClientEvent blk
TraceFoundIntersection
                Point blk
intersection (AnchoredFragment (Header blk) -> Our (Tip blk)
forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk) -> Our (Tip blk)
ourTipFromChain AnchoredFragment (Header blk)
ourFrag) Their (Tip blk)
theirTip
        m (Consensus (ClientPipelinedStIdle 'Z) blk m)
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall a. m a -> m a
traceException (m (Consensus (ClientPipelinedStIdle 'Z) blk m)
 -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall a b. (a -> b) -> a -> b
$ do
            -- Roll back the current chain fragment to the @intersection@.
            --
            -- While the primitives in the ChainSync protocol are "roll back",
            -- "roll forward (apply block)", etc. The /real/ primitive is
            -- "switch to fork", which means that a roll back is always
            -- followed by applying at least as many blocks that we rolled
            -- back.
            --
            -- This is important for 'rewindHeaderStateHistory', which can only
            -- roll back up to @k@ blocks, /once/, i.e., we cannot keep rolling
            -- back the same chain state multiple times, because that would
            -- mean that we store the chain state for the /whole chain/, all
            -- the way to genesis.
            --
            -- So the rewind below is fine when we are switching to a fork
            -- (i.e. it is followed by rolling forward again), but we need some
            -- guarantees that the ChainSync protocol /does/ in fact give us a
            -- switch-to-fork instead of a true rollback.
            (theirFrag, theirHeaderStateHistory) <- do
                case Point blk
-> (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk)
-> Maybe
     (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk,
      Maybe (HeaderStateWithTime blk))
forall blk.
(BlockSupportsProtocol blk, HasAnnTip blk) =>
Point blk
-> (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk)
-> Maybe
     (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk,
      Maybe (HeaderStateWithTime blk))
attemptRollback
                         Point blk
intersection
                         -- We only perform the linear computation
                         -- required by 'withTime' once when finding
                         -- an intersection with a peer, so this
                         -- should not impact the performance.
                         (AnchoredFragment (Header blk)
ourFrag AnchoredFragment (Header blk)
-> HeaderStateHistory blk -> AnchoredFragment (HeaderWithTime blk)
forall blk.
(Typeable blk, HasHeader (Header blk)) =>
AnchoredFragment (Header blk)
-> HeaderStateHistory blk -> AnchoredFragment (HeaderWithTime blk)
`withTime` HeaderStateHistory blk
ourHeaderStateHistory, HeaderStateHistory blk
ourHeaderStateHistory)
                  of
                    Just (AnchoredFragment (HeaderWithTime blk)
c, HeaderStateHistory blk
d, Maybe (HeaderStateWithTime blk)
_oldestRewound) -> (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk)
-> m (AnchoredFragment (HeaderWithTime blk),
      HeaderStateHistory blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredFragment (HeaderWithTime blk)
c, HeaderStateHistory blk
d)
                    Maybe
  (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk,
   Maybe (HeaderStateWithTime blk))
Nothing ->
                        -- The @intersection@ is not on our fragment, even
                        -- though we sent only points from our fragment to find
                        -- an intersection with. The node must have sent us an
                        -- invalid intersection point.
                        ChainSyncClientException
-> m (AnchoredFragment (HeaderWithTime blk),
      HeaderStateHistory blk)
forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect
                      (ChainSyncClientException
 -> m (AnchoredFragment (HeaderWithTime blk),
       HeaderStateHistory blk))
-> ChainSyncClientException
-> m (AnchoredFragment (HeaderWithTime blk),
      HeaderStateHistory blk)
forall a b. (a -> b) -> a -> b
$ Point blk
-> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientException
forall blk.
BlockSupportsProtocol blk =>
Point blk
-> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientException
InvalidIntersection
                            Point blk
intersection (AnchoredFragment (Header blk) -> Our (Tip blk)
forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk) -> Our (Tip blk)
ourTipFromChain AnchoredFragment (Header blk)
ourFrag) Their (Tip blk)
theirTip
            let kis =
                   ConsensusConfig (BlockProtocol blk)
-> KnownIntersectionState blk -> KnownIntersectionState blk
forall blk.
(HasHeader blk, HasHeader (Header blk), HasAnnTip blk,
 ConsensusProtocol (BlockProtocol blk), HasCallStack) =>
ConsensusConfig (BlockProtocol blk)
-> KnownIntersectionState blk -> KnownIntersectionState blk
assertKnownIntersectionInvariants (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
                 (KnownIntersectionState blk -> KnownIntersectionState blk)
-> KnownIntersectionState blk -> KnownIntersectionState blk
forall a b. (a -> b) -> a -> b
$ KnownIntersectionState {
                       mostRecentIntersection :: Point blk
mostRecentIntersection  = Point blk
intersection
                     , AnchoredFragment (Header blk)
ourFrag :: AnchoredFragment (Header blk)
ourFrag :: AnchoredFragment (Header blk)
ourFrag
                     , AnchoredFragment (HeaderWithTime blk)
theirFrag :: AnchoredFragment (HeaderWithTime blk)
theirFrag :: AnchoredFragment (HeaderWithTime blk)
theirFrag
                     , HeaderStateHistory blk
theirHeaderStateHistory :: HeaderStateHistory blk
theirHeaderStateHistory :: HeaderStateHistory blk
theirHeaderStateHistory
                     , kBestBlockNo :: BlockNo
kBestBlockNo            = BlockNo
uBestBlockNo
                     }
            atomically $ do
              updateJumpInfoSTM jumping kis
              setCandidate theirFrag
              setLatestSlot dynEnv (AF.headSlot theirFrag)
            continueWithState kis $
                knownIntersectionStateTop cfgEnv dynEnv intEnv theirTip

-- | Augment the given fragment of headers with the times specified in
-- the given state history.
--
-- PRECONDITION: the fragment must be a prefix of the state history.
--
withTime ::
     (Typeable blk, HasHeader (Header blk))
  => AnchoredFragment (Header blk)
  -> HeaderStateHistory blk
  -> AnchoredFragment (HeaderWithTime blk)
withTime :: forall blk.
(Typeable blk, HasHeader (Header blk)) =>
AnchoredFragment (Header blk)
-> HeaderStateHistory blk -> AnchoredFragment (HeaderWithTime blk)
withTime AnchoredFragment (Header blk)
fragment (HeaderStateHistory AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history) =
    Either String ()
-> AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk)
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (
      if AnchoredFragment (Header blk) -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment (Header blk)
fragment Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history
      then () -> Either String ()
forall a b. b -> Either a b
Right ()
      else String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Fragment and history have different lengths (|fragment| = "
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (AnchoredFragment (Header blk) -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment (Header blk)
fragment)
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", |history| = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history)
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
      ) (AnchoredFragment (HeaderWithTime blk)
 -> AnchoredFragment (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$
    Anchor (HeaderWithTime blk)
-> [HeaderWithTime blk] -> AnchoredFragment (HeaderWithTime blk)
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst
        (Anchor (Header blk) -> Anchor (HeaderWithTime blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor (Anchor (Header blk) -> Anchor (HeaderWithTime blk))
-> Anchor (Header blk) -> Anchor (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment (Header blk)
fragment)
        ([HeaderWithTime blk] -> AnchoredFragment (HeaderWithTime blk))
-> [HeaderWithTime blk] -> AnchoredFragment (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$ ((Header blk, HeaderStateWithTime blk) -> HeaderWithTime blk)
-> [(Header blk, HeaderStateWithTime blk)] -> [HeaderWithTime blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Header blk, HeaderStateWithTime blk) -> HeaderWithTime blk
forall blk.
(Header blk, HeaderStateWithTime blk) -> HeaderWithTime blk
addTimeToHeader ([(Header blk, HeaderStateWithTime blk)] -> [HeaderWithTime blk])
-> [(Header blk, HeaderStateWithTime blk)] -> [HeaderWithTime blk]
forall a b. (a -> b) -> a -> b
$ [Header blk]
-> [HeaderStateWithTime blk]
-> [(Header blk, HeaderStateWithTime blk)]
forall a b. [a] -> [b] -> [(a, b)]
zip (AnchoredFragment (Header blk) -> [Header blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment (Header blk)
fragment) (AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> [HeaderStateWithTime blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
history)
  where
     addTimeToHeader :: (Header blk, HeaderStateWithTime blk) -> HeaderWithTime blk
     addTimeToHeader :: forall blk.
(Header blk, HeaderStateWithTime blk) -> HeaderWithTime blk
addTimeToHeader (Header blk
hdr, HeaderStateWithTime blk
hsWt) = HeaderWithTime {
         hwtHeader :: Header blk
hwtHeader = Header blk
hdr
       , hwtSlotRelativeTime :: RelativeTime
hwtSlotRelativeTime = HeaderStateWithTime blk -> RelativeTime
forall blk. HeaderStateWithTime blk -> RelativeTime
hswtSlotTime HeaderStateWithTime blk
hsWt
     }

{-------------------------------------------------------------------------------
  Processing 'MsgRollForward' and 'MsgRollBackward'
-------------------------------------------------------------------------------}

knownIntersectionStateTop ::
  forall m blk arrival judgment.
     ( IOLike m
     , LedgerSupportsProtocol blk
     )
  => ConfigEnv m blk
  -> DynamicEnv m blk
  -> InternalEnv m blk arrival judgment
  -> Their (Tip blk)
  -> Stateful m blk
         (KnownIntersectionState blk)
         (ClientPipelinedStIdle 'Z)
knownIntersectionStateTop :: forall (m :: * -> *) blk arrival judgment.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk
-> InternalEnv m blk arrival judgment
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
knownIntersectionStateTop ConfigEnv m blk
cfgEnv DynamicEnv m blk
dynEnv InternalEnv m blk arrival judgment
intEnv =
    MkPipelineDecision
-> Nat 'Z
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
forall (n :: N).
MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
nextStep MkPipelineDecision
mkPipelineDecision0 Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero
      -- The 'MkPiplineDecision' and @'Nat' n@ arguments below could safely be
      -- merged into the 'KnownIntersectionState' record type, but it's
      -- unfortunately quite awkward to do so.
  where
    ConfigEnv {
        MkPipelineDecision
mkPipelineDecision0 :: forall (m :: * -> *) blk. ConfigEnv m blk -> MkPipelineDecision
mkPipelineDecision0 :: MkPipelineDecision
mkPipelineDecision0
      , Tracer m (TraceChainSyncClientEvent blk)
tracer :: forall (m :: * -> *) blk.
ConfigEnv m blk -> Tracer m (TraceChainSyncClientEvent blk)
tracer :: Tracer m (TraceChainSyncClientEvent blk)
tracer
      , TopLevelConfig blk
cfg :: forall (m :: * -> *) blk. ConfigEnv m blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
      , HistoricityCheck m blk
historicityCheck :: forall (m :: * -> *) blk. ConfigEnv m blk -> HistoricityCheck m blk
historicityCheck :: HistoricityCheck m blk
historicityCheck
      } = ConfigEnv m blk
cfgEnv

    DynamicEnv {
        ControlMessageSTM m
controlMessageSTM :: forall (m :: * -> *) blk. DynamicEnv m blk -> ControlMessageSTM m
controlMessageSTM :: ControlMessageSTM m
controlMessageSTM
      , HeaderMetricsTracer m
headerMetricsTracer :: forall (m :: * -> *) blk. DynamicEnv m blk -> HeaderMetricsTracer m
headerMetricsTracer :: HeaderMetricsTracer m
headerMetricsTracer
      , Idling m
idling :: forall (m :: * -> *) blk. DynamicEnv m blk -> Idling m
idling :: Idling m
idling
      , LoPBucket m
loPBucket :: forall (m :: * -> *) blk. DynamicEnv m blk -> LoPBucket m
loPBucket :: LoPBucket m
loPBucket
      , AnchoredFragment (HeaderWithTime blk) -> STM m ()
setCandidate :: forall (m :: * -> *) blk.
DynamicEnv m blk
-> AnchoredFragment (HeaderWithTime blk) -> STM m ()
setCandidate :: AnchoredFragment (HeaderWithTime blk) -> STM m ()
setCandidate
      , Jumping m blk
jumping :: forall (m :: * -> *) blk. DynamicEnv m blk -> Jumping m blk
jumping :: Jumping m blk
jumping
      } = DynamicEnv m blk
dynEnv

    InternalEnv {
        forall s (n :: N).
NoThunks s =>
Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> forall s (n :: N).
   NoThunks s =>
   Nat n
   -> Stateful m blk s (ClientPipelinedStIdle 'Z)
   -> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe :: forall s (n :: N).
NoThunks s =>
Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe
      , HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck :: HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck
      , forall (n :: N).
Nat n
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle n) blk m)
terminateAfterDrain :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> forall (n :: N).
   Nat n
   -> ChainSyncClientResult
   -> m (Consensus (ClientPipelinedStIdle n) blk m)
terminateAfterDrain :: forall (n :: N).
Nat n
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle n) blk m)
terminateAfterDrain
      , forall a. m a -> m a
traceException :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment -> forall a. m a -> m a
traceException :: forall a. m a -> m a
traceException
      } = InternalEnv m blk arrival judgment
intEnv

    InFutureCheck.HeaderInFutureCheck {
        Header blk -> m arrival
recordHeaderArrival :: Header blk -> m arrival
recordHeaderArrival :: forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> Header blk -> m arrival
recordHeaderArrival
      } = HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck

    -- Request the next message (roll forward or backward).
    --
    -- This is also the place where we checked whether we're asked to terminate
    -- by the mux layer or to wait and perform a CSJ jump.
    nextStep ::
        MkPipelineDecision
     -> Nat n
     -> Their (Tip blk)
     -> Stateful m blk
            (KnownIntersectionState blk)
            (ClientPipelinedStIdle n)
    nextStep :: forall (n :: N).
MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
nextStep MkPipelineDecision
mkPipelineDecision Nat n
n Their (Tip blk)
theirTip = (KnownIntersectionState blk
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall (m :: * -> *) blk s
       (st :: * -> * -> * -> (* -> *) -> * -> *).
(s -> m (Consensus st blk m)) -> Stateful m blk s st
Stateful ((KnownIntersectionState blk
  -> m (Consensus (ClientPipelinedStIdle n) blk m))
 -> Stateful
      m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n))
-> (KnownIntersectionState blk
    -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall a b. (a -> b) -> a -> b
$ \KnownIntersectionState blk
kis ->
        ControlMessageSTM m -> m ControlMessage
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically ControlMessageSTM m
controlMessageSTM m ControlMessage
-> (ControlMessage
    -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            -- We have been asked to terminate the client
            ControlMessage
Terminate -> Nat n
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall (n :: N).
Nat n
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle n) blk m)
terminateAfterDrain Nat n
n (ChainSyncClientResult
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$ ChainSyncClientResult
AskedToTerminate
            ControlMessage
_continue -> do
                -- Wait until next jumping instruction, which can be either to
                -- jump, to run normal ChainSync, or to restart the ChainSync
                -- client.
                -- Pause LoP while waiting, we'll resume it if we get `RunNormally`
                -- or `Restart`.
                Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer TraceChainSyncClientEvent blk
forall blk. TraceChainSyncClientEvent blk
TraceJumpingWaitingForNextInstruction
                LoPBucket m -> m ()
forall (m :: * -> *). LoPBucket m -> m ()
lbPause LoPBucket m
loPBucket
                instruction <- Jumping m blk -> m (Instruction blk)
forall (m :: * -> *) blk. Jumping m blk -> m (Instruction blk)
Jumping.jgNextInstruction Jumping m blk
jumping
                traceWith tracer $ TraceJumpingInstructionIs instruction
                case instruction of
                    Jumping.JumpInstruction JumpInstruction blk
jumpInstruction ->
                      KnownIntersectionState blk
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState KnownIntersectionState blk
kis
                        (Stateful
   m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$ Nat n
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall s (n :: N).
NoThunks s =>
Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe Nat n
n
                        (Stateful
   m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
 -> Stateful
      m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall a b. (a -> b) -> a -> b
$ MkPipelineDecision
-> JumpInstruction blk
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
offerJump MkPipelineDecision
mkPipelineDecision JumpInstruction blk
jumpInstruction
                    Instruction blk
Jumping.RunNormally -> do
                      LoPBucket m -> m ()
forall (m :: * -> *). LoPBucket m -> m ()
lbResume LoPBucket m
loPBucket
                      KnownIntersectionState blk
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState KnownIntersectionState blk
kis
                        (Stateful
   m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$ MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall (n :: N).
MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
nextStep' MkPipelineDecision
mkPipelineDecision Nat n
n Their (Tip blk)
theirTip
                    Instruction blk
Jumping.Restart -> do
                      LoPBucket m -> m ()
forall (m :: * -> *). LoPBucket m -> m ()
lbResume LoPBucket m
loPBucket
                      ()
-> Stateful m blk () (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState ()
                        (Stateful m blk () (ClientPipelinedStIdle n)
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful m blk () (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$ Nat n
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
-> Stateful m blk () (ClientPipelinedStIdle n)
forall s (n :: N).
NoThunks s =>
Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe Nat n
n
                        (Stateful m blk () (ClientPipelinedStIdle 'Z)
 -> Stateful m blk () (ClientPipelinedStIdle n))
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
-> Stateful m blk () (ClientPipelinedStIdle n)
forall a b. (a -> b) -> a -> b
$ ConfigEnv m blk
-> DynamicEnv m blk
-> InternalEnv m blk arrival judgment
-> BlockNo
-> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
forall (m :: * -> *) blk arrival judgment.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk
-> InternalEnv m blk arrival judgment
-> BlockNo
-> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
findIntersectionTop
                            ConfigEnv m blk
cfgEnv
                            DynamicEnv m blk
dynEnv
                            InternalEnv m blk arrival judgment
intEnv
                            (KnownIntersectionState blk -> BlockNo
forall blk. KnownIntersectionState blk -> BlockNo
kBestBlockNo KnownIntersectionState blk
kis)
                            Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult
forall blk.
BlockSupportsProtocol blk =>
Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult
NoMoreIntersection

    nextStep' ::
        MkPipelineDecision
     -> Nat n
     -> Their (Tip blk)
     -> Stateful m blk
            (KnownIntersectionState blk)
            (ClientPipelinedStIdle n)
    nextStep' :: forall (n :: N).
MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
nextStep' MkPipelineDecision
mkPipelineDecision Nat n
n Their (Tip blk)
theirTip =
        (KnownIntersectionState blk
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall (m :: * -> *) blk s
       (st :: * -> * -> * -> (* -> *) -> * -> *).
(s -> m (Consensus st blk m)) -> Stateful m blk s st
Stateful ((KnownIntersectionState blk
  -> m (Consensus (ClientPipelinedStIdle n) blk m))
 -> Stateful
      m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n))
-> (KnownIntersectionState blk
    -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall a b. (a -> b) -> a -> b
$ \KnownIntersectionState blk
kis ->
          Consensus (ClientPipelinedStIdle n) blk m
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Consensus (ClientPipelinedStIdle n) blk m
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Consensus (ClientPipelinedStIdle n) blk m
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$
            KnownIntersectionState blk
-> MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> WithOrigin BlockNo
-> Consensus (ClientPipelinedStIdle n) blk m
forall (n :: N).
KnownIntersectionState blk
-> MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> WithOrigin BlockNo
-> Consensus (ClientPipelinedStIdle n) blk m
requestNext
              KnownIntersectionState blk
kis
              MkPipelineDecision
mkPipelineDecision
              Nat n
n
              Their (Tip blk)
theirTip
              (AnchoredFragment (HeaderWithTime blk) -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo (KnownIntersectionState blk -> AnchoredFragment (HeaderWithTime blk)
forall blk.
KnownIntersectionState blk -> AnchoredFragment (HeaderWithTime blk)
theirFrag KnownIntersectionState blk
kis))

    offerJump ::
        MkPipelineDecision
     -> Jumping.JumpInstruction blk
     -> Stateful m blk
            (KnownIntersectionState blk)
            (ClientPipelinedStIdle Z)
    offerJump :: MkPipelineDecision
-> JumpInstruction blk
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
offerJump MkPipelineDecision
mkPipelineDecision JumpInstruction blk
jump = (KnownIntersectionState blk
 -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
forall (m :: * -> *) blk s
       (st :: * -> * -> * -> (* -> *) -> * -> *).
(s -> m (Consensus st blk m)) -> Stateful m blk s st
Stateful ((KnownIntersectionState blk
  -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
 -> Stateful
      m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z))
-> (KnownIntersectionState blk
    -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
forall a b. (a -> b) -> a -> b
$ \KnownIntersectionState blk
kis -> do
        let jumpInfo :: JumpInfo blk
jumpInfo = case JumpInstruction blk
jump of
              Jumping.JumpTo JumpInfo blk
ji          -> JumpInfo blk
ji
              Jumping.JumpToGoodPoint JumpInfo blk
ji -> JumpInfo blk
ji
            dynamoTipPt :: Point blk
dynamoTipPt = Point (HeaderWithTime blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (HeaderWithTime blk) -> Point blk)
-> Point (HeaderWithTime blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (HeaderWithTime blk) -> Point (HeaderWithTime blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (HeaderWithTime blk)
 -> Point (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
-> Point (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
jumpInfo
        Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> TraceChainSyncClientEvent blk
forall blk. Point blk -> TraceChainSyncClientEvent blk
TraceOfferJump Point blk
dynamoTipPt
        Consensus (ClientPipelinedStIdle 'Z) blk m
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Consensus (ClientPipelinedStIdle 'Z) blk m
 -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> Consensus (ClientPipelinedStIdle 'Z) blk m
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall a b. (a -> b) -> a -> b
$
            [Point blk]
-> ClientPipelinedStIntersect
     (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> Consensus (ClientPipelinedStIdle 'Z) blk m
forall point header tip (m :: * -> *) a.
[point]
-> ClientPipelinedStIntersect header point tip m a
-> ClientPipelinedStIdle 'Z header point tip m a
SendMsgFindIntersect [Point blk
dynamoTipPt] (ClientPipelinedStIntersect
   (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
 -> Consensus (ClientPipelinedStIdle 'Z) blk m)
-> ClientPipelinedStIntersect
     (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> Consensus (ClientPipelinedStIdle 'Z) blk m
forall a b. (a -> b) -> a -> b
$
            ClientPipelinedStIntersect {
              recvMsgIntersectFound :: Point blk
-> Tip blk -> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
recvMsgIntersectFound = \Point blk
pt Tip blk
theirTip ->
                  if
                    | Point blk
pt Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
dynamoTipPt -> do
                      Jumping m blk -> JumpResult blk -> m ()
forall (m :: * -> *) blk. Jumping m blk -> JumpResult blk -> m ()
Jumping.jgProcessJumpResult Jumping m blk
jumping (JumpResult blk -> m ()) -> JumpResult blk -> m ()
forall a b. (a -> b) -> a -> b
$ JumpInstruction blk -> JumpResult blk
forall blk. JumpInstruction blk -> JumpResult blk
Jumping.AcceptedJump JumpInstruction blk
jump
                      Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ JumpResult blk -> TraceChainSyncClientEvent blk
forall blk. JumpResult blk -> TraceChainSyncClientEvent blk
TraceJumpResult (JumpResult blk -> TraceChainSyncClientEvent blk)
-> JumpResult blk -> TraceChainSyncClientEvent blk
forall a b. (a -> b) -> a -> b
$ JumpInstruction blk -> JumpResult blk
forall blk. JumpInstruction blk -> JumpResult blk
Jumping.AcceptedJump JumpInstruction blk
jump
                      let kis' :: KnownIntersectionState blk
kis' = case JumpInstruction blk
jump of
                            -- Since the updated kis is needed to validate headers,
                            -- we only update it if we are becoming a Dynamo or
                            -- an objector
                            Jumping.JumpToGoodPoint{} -> KnownIntersectionState blk
-> JumpInfo blk -> KnownIntersectionState blk
combineJumpInfo KnownIntersectionState blk
kis JumpInfo blk
jumpInfo
                            JumpInstruction blk
_ -> KnownIntersectionState blk
kis
                      KnownIntersectionState blk
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState KnownIntersectionState blk
kis' (Stateful
   m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
 -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall a b. (a -> b) -> a -> b
$ MkPipelineDecision
-> Nat 'Z
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
forall (n :: N).
MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
nextStep MkPipelineDecision
mkPipelineDecision Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero (Tip blk -> Their (Tip blk)
forall a. a -> Their a
Their Tip blk
theirTip)
                    | Bool
otherwise         -> ChainSyncClientException
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ChainSyncClientException
InvalidJumpResponse
            ,
              recvMsgIntersectNotFound :: Tip blk -> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
recvMsgIntersectNotFound = \Tip blk
theirTip -> do
                Jumping m blk -> JumpResult blk -> m ()
forall (m :: * -> *) blk. Jumping m blk -> JumpResult blk -> m ()
Jumping.jgProcessJumpResult Jumping m blk
jumping (JumpResult blk -> m ()) -> JumpResult blk -> m ()
forall a b. (a -> b) -> a -> b
$ JumpInstruction blk -> JumpResult blk
forall blk. JumpInstruction blk -> JumpResult blk
Jumping.RejectedJump JumpInstruction blk
jump
                Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ JumpResult blk -> TraceChainSyncClientEvent blk
forall blk. JumpResult blk -> TraceChainSyncClientEvent blk
TraceJumpResult (JumpResult blk -> TraceChainSyncClientEvent blk)
-> JumpResult blk -> TraceChainSyncClientEvent blk
forall a b. (a -> b) -> a -> b
$ JumpInstruction blk -> JumpResult blk
forall blk. JumpInstruction blk -> JumpResult blk
Jumping.RejectedJump JumpInstruction blk
jump
                KnownIntersectionState blk
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState KnownIntersectionState blk
kis (Stateful
   m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
 -> m (Consensus (ClientPipelinedStIdle 'Z) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
-> m (Consensus (ClientPipelinedStIdle 'Z) blk m)
forall a b. (a -> b) -> a -> b
$ MkPipelineDecision
-> Nat 'Z
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle 'Z)
forall (n :: N).
MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
nextStep MkPipelineDecision
mkPipelineDecision Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero (Tip blk -> Their (Tip blk)
forall a. a -> Their a
Their Tip blk
theirTip)
            }
        where
          combineJumpInfo ::
               KnownIntersectionState blk
            -> JumpInfo blk
            -> KnownIntersectionState blk
          combineJumpInfo :: KnownIntersectionState blk
-> JumpInfo blk -> KnownIntersectionState blk
combineJumpInfo KnownIntersectionState blk
kis JumpInfo blk
ji =
            let mRewoundHistory :: Maybe (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
mRewoundHistory =
                  Point blk
-> HeaderStateHistory blk
-> Maybe (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
forall blk.
HasAnnTip blk =>
Point blk
-> HeaderStateHistory blk
-> Maybe (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
HeaderStateHistory.rewind
                    (Point (HeaderWithTime blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
AF.castPoint (Point (HeaderWithTime blk) -> Point blk)
-> Point (HeaderWithTime blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (HeaderWithTime blk) -> Point (HeaderWithTime blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (AnchoredFragment (HeaderWithTime blk)
 -> Point (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
-> Point (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
ji)
                    (JumpInfo blk -> HeaderStateHistory blk
forall blk. JumpInfo blk -> HeaderStateHistory blk
jTheirHeaderStateHistory JumpInfo blk
ji)
                -- We assume the history is always possible to rewind. The case
                -- where this wouldn't be true is if the original candidate
                -- fragment provided by the dynamo contained headers that have
                -- no corresponding header state.
                (HeaderStateHistory blk
rewoundHistory, Maybe (HeaderStateWithTime blk)
_oldestRewound) =
                  (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
-> Maybe (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
-> (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
forall a. a -> Maybe a -> a
fromMaybe (String -> (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
forall a. HasCallStack => String -> a
error String
"offerJump: cannot rewind history") Maybe (HeaderStateHistory blk, Maybe (HeaderStateWithTime blk))
mRewoundHistory
                -- If the tip of jTheirFragment does not match the tip of
                -- jTheirHeaderStateHistory, then the history needs rewinding.
                historyNeedsRewinding :: Bool
historyNeedsRewinding =
                     (Point (HeaderWithTime blk) -> Point (HeaderWithTime blk) -> Bool
forall a. Eq a => a -> a -> Bool
/= AnchoredFragment (HeaderWithTime blk) -> Point (HeaderWithTime blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint (JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
ji)) (Point (HeaderWithTime blk) -> Bool)
-> Point (HeaderWithTime blk) -> Bool
forall a b. (a -> b) -> a -> b
$
                     Point blk -> Point (HeaderWithTime blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point blk -> Point (HeaderWithTime blk))
-> Point blk -> Point (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$
                     HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint (HeaderState blk -> Point blk)
-> (Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
    -> HeaderState blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderStateWithTime blk -> HeaderState blk
forall blk. HeaderStateWithTime blk -> HeaderState blk
hswtHeaderState (HeaderStateWithTime blk -> HeaderState blk)
-> (Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
    -> HeaderStateWithTime blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
-> HeaderState blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderStateWithTime blk -> HeaderStateWithTime blk)
-> (HeaderStateWithTime blk -> HeaderStateWithTime blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
-> HeaderStateWithTime blk
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HeaderStateWithTime blk -> HeaderStateWithTime blk
forall a. a -> a
id HeaderStateWithTime blk -> HeaderStateWithTime blk
forall a. a -> a
id (Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
 -> Point blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
-> Point blk
forall a b. (a -> b) -> a -> b
$
                     AnchoredSeq
  (WithOrigin SlotNo)
  (HeaderStateWithTime blk)
  (HeaderStateWithTime blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head (AnchoredSeq
   (WithOrigin SlotNo)
   (HeaderStateWithTime blk)
   (HeaderStateWithTime blk)
 -> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk))
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
-> Either (HeaderStateWithTime blk) (HeaderStateWithTime blk)
forall a b. (a -> b) -> a -> b
$
                     HeaderStateHistory blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
forall blk.
HeaderStateHistory blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
HeaderStateHistory.unHeaderStateHistory (HeaderStateHistory blk
 -> AnchoredSeq
      (WithOrigin SlotNo)
      (HeaderStateWithTime blk)
      (HeaderStateWithTime blk))
-> HeaderStateHistory blk
-> AnchoredSeq
     (WithOrigin SlotNo)
     (HeaderStateWithTime blk)
     (HeaderStateWithTime blk)
forall a b. (a -> b) -> a -> b
$
                     JumpInfo blk -> HeaderStateHistory blk
forall blk. JumpInfo blk -> HeaderStateHistory blk
jTheirHeaderStateHistory JumpInfo blk
ji
                -- Recompute the intersection only if a suffix of the candidate
                -- fragment was trimmed.
                intersection :: Point blk
intersection
                  | Bool
historyNeedsRewinding = case AnchoredFragment (Header blk)
-> AnchoredFragment (HeaderWithTime blk)
-> Maybe (Point (Header blk))
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2 -> Maybe (Point block1)
AF.intersectionPoint (JumpInfo blk -> AnchoredFragment (Header blk)
forall blk. JumpInfo blk -> AnchoredFragment (Header blk)
jOurFragment JumpInfo blk
ji) (JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
ji) of
                      Just Point (Header blk)
po -> Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point (Header blk)
po
                      Maybe (Point (Header blk))
Nothing -> String -> Point blk
forall a. HasCallStack => String -> a
error String
"offerJump: the jumpInfo should have a valid intersection"
                  | Bool
otherwise = JumpInfo blk -> Point blk
forall blk. JumpInfo blk -> Point blk
jMostRecentIntersection JumpInfo blk
ji
             in KnownIntersectionState
                  { mostRecentIntersection :: Point blk
mostRecentIntersection = Point blk
intersection
                  , ourFrag :: AnchoredFragment (Header blk)
ourFrag = JumpInfo blk -> AnchoredFragment (Header blk)
forall blk. JumpInfo blk -> AnchoredFragment (Header blk)
jOurFragment JumpInfo blk
ji
                  , theirFrag :: AnchoredFragment (HeaderWithTime blk)
theirFrag = JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
ji
                  , theirHeaderStateHistory :: HeaderStateHistory blk
theirHeaderStateHistory = HeaderStateHistory blk
rewoundHistory
                  , kBestBlockNo :: BlockNo
kBestBlockNo = BlockNo -> BlockNo -> BlockNo
forall a. Ord a => a -> a -> a
max (BlockNo -> WithOrigin BlockNo -> BlockNo
forall t. t -> WithOrigin t -> t
fromWithOrigin BlockNo
0 (WithOrigin BlockNo -> BlockNo) -> WithOrigin BlockNo -> BlockNo
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (HeaderWithTime blk) -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo (AnchoredFragment (HeaderWithTime blk) -> WithOrigin BlockNo)
-> AnchoredFragment (HeaderWithTime blk) -> WithOrigin BlockNo
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
ji) (KnownIntersectionState blk -> BlockNo
forall blk. KnownIntersectionState blk -> BlockNo
kBestBlockNo KnownIntersectionState blk
kis)
                  }

    requestNext ::
        KnownIntersectionState blk
     -> MkPipelineDecision
     -> Nat n
     -> Their (Tip blk)
     -> WithOrigin BlockNo
     -> Consensus (ClientPipelinedStIdle n) blk m
    requestNext :: forall (n :: N).
KnownIntersectionState blk
-> MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> WithOrigin BlockNo
-> Consensus (ClientPipelinedStIdle n) blk m
requestNext KnownIntersectionState blk
kis MkPipelineDecision
mkPipelineDecision Nat n
n Their (Tip blk)
theirTip WithOrigin BlockNo
candTipBlockNo =
        let theirTipBlockNo :: WithOrigin BlockNo
theirTipBlockNo = Tip blk -> WithOrigin BlockNo
forall {k} (b :: k). Tip b -> WithOrigin BlockNo
getTipBlockNo (Their (Tip blk) -> Tip blk
forall a. Their a -> a
unTheir Their (Tip blk)
theirTip)
            decision :: (PipelineDecision n, MkPipelineDecision)
decision        =
                MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> (PipelineDecision n, MkPipelineDecision)
forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> (PipelineDecision n, MkPipelineDecision)
runPipelineDecision
                    MkPipelineDecision
mkPipelineDecision
                    Nat n
n
                    WithOrigin BlockNo
candTipBlockNo
                    WithOrigin BlockNo
theirTipBlockNo
            onMsgAwaitReply :: m ()
onMsgAwaitReply = do
              HistoricityCheck m blk
-> HistoricalChainSyncMessage
-> HeaderStateWithTime blk
-> m (Either HistoricityException ())
forall (m :: * -> *) blk.
HistoricityCheck m blk
-> HistoricalChainSyncMessage
-> HeaderStateWithTime blk
-> m (Either HistoricityException ())
HistoricityCheck.judgeMessageHistoricity
                HistoricityCheck m blk
historicityCheck
                HistoricalChainSyncMessage
HistoricalMsgAwaitReply
                (HeaderStateHistory blk -> HeaderStateWithTime blk
forall blk. HeaderStateHistory blk -> HeaderStateWithTime blk
HeaderStateHistory.current (KnownIntersectionState blk -> HeaderStateHistory blk
forall blk. KnownIntersectionState blk -> HeaderStateHistory blk
theirHeaderStateHistory KnownIntersectionState blk
kis)) m (Either HistoricityException ())
-> (Either HistoricityException () -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Left HistoricityException
ex  -> ChainSyncClientException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ChainSyncClientException -> m ())
-> ChainSyncClientException -> m ()
forall a b. (a -> b) -> a -> b
$ HistoricityException -> ChainSyncClientException
HistoricityError HistoricityException
ex
                  Right () -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Idling m -> m ()
forall (m :: * -> *). Idling m -> m ()
idlingStart Idling m
idling
              LoPBucket m -> m ()
forall (m :: * -> *). LoPBucket m -> m ()
lbPause LoPBucket m
loPBucket
              Jumping m blk -> m ()
forall (m :: * -> *) blk. Jumping m blk -> m ()
Jumping.jgOnAwaitReply Jumping m blk
jumping
        in
        case (Nat n
n, (PipelineDecision n, MkPipelineDecision)
decision) of
          (Nat n
Zero, (PipelineDecision n
Request, MkPipelineDecision
mkPipelineDecision')) ->
              m ()
-> ClientStNext
     'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> Consensus (ClientPipelinedStIdle 'Z) blk m
forall (m :: * -> *) header point tip a.
m ()
-> ClientStNext 'Z header point tip m a
-> ClientPipelinedStIdle 'Z header point tip m a
SendMsgRequestNext
                  m ()
onMsgAwaitReply
                  (KnownIntersectionState blk
-> MkPipelineDecision
-> Nat 'Z
-> ClientStNext
     'Z (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall (n :: N).
KnownIntersectionState blk
-> MkPipelineDecision -> Nat n -> Consensus (ClientStNext n) blk m
handleNext KnownIntersectionState blk
kis MkPipelineDecision
mkPipelineDecision' Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero)

          (Nat n
_, (PipelineDecision n
Pipeline, MkPipelineDecision
mkPipelineDecision')) ->
              m ()
-> ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> Consensus (ClientPipelinedStIdle n) blk m
forall (m :: * -> *) (n :: N) header point tip a.
m ()
-> ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
SendMsgRequestNextPipelined
                m ()
onMsgAwaitReply
            (ClientPipelinedStIdle
   ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
 -> Consensus (ClientPipelinedStIdle n) blk m)
-> ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> Consensus (ClientPipelinedStIdle n) blk m
forall a b. (a -> b) -> a -> b
$ KnownIntersectionState blk
-> MkPipelineDecision
-> Nat ('S n)
-> Their (Tip blk)
-> WithOrigin BlockNo
-> ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall (n :: N).
KnownIntersectionState blk
-> MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> WithOrigin BlockNo
-> Consensus (ClientPipelinedStIdle n) blk m
requestNext
                  KnownIntersectionState blk
kis
                  MkPipelineDecision
mkPipelineDecision'
                  (Nat n -> Nat ('S n)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n)
                  Their (Tip blk)
theirTip
                  WithOrigin BlockNo
candTipBlockNo

          (Succ Nat n
n', (PipelineDecision n
CollectOrPipeline, MkPipelineDecision
mkPipelineDecision')) ->
              Maybe
  (m (ClientPipelinedStIdle
        ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
-> ClientStNext
     n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CollectResponse
                  (   m (ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
-> Maybe
     (m (ClientPipelinedStIdle
           ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
forall a. a -> Maybe a
Just
                    (m (ClientPipelinedStIdle
      ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
 -> Maybe
      (m (ClientPipelinedStIdle
            ('S n)
            (Header blk)
            (Point blk)
            (Tip blk)
            m
            ChainSyncClientResult)))
-> m (ClientPipelinedStIdle
        ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
-> Maybe
     (m (ClientPipelinedStIdle
           ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
forall a b. (a -> b) -> a -> b
$ ClientPipelinedStIdle
  ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> m (ClientPipelinedStIdle
        ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    (ClientPipelinedStIdle
   ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
 -> m (ClientPipelinedStIdle
         ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
-> ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> m (ClientPipelinedStIdle
        ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall a b. (a -> b) -> a -> b
$ m ()
-> ClientPipelinedStIdle
     ('S ('S n))
     (Header blk)
     (Point blk)
     (Tip blk)
     m
     ChainSyncClientResult
-> ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall (m :: * -> *) (n :: N) header point tip a.
m ()
-> ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
SendMsgRequestNextPipelined
                        m ()
onMsgAwaitReply
                    (ClientPipelinedStIdle
   ('S ('S n))
   (Header blk)
   (Point blk)
   (Tip blk)
   m
   ChainSyncClientResult
 -> ClientPipelinedStIdle
      ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
-> ClientPipelinedStIdle
     ('S ('S n))
     (Header blk)
     (Point blk)
     (Tip blk)
     m
     ChainSyncClientResult
-> ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall a b. (a -> b) -> a -> b
$ KnownIntersectionState blk
-> MkPipelineDecision
-> Nat ('S ('S n))
-> Their (Tip blk)
-> WithOrigin BlockNo
-> ClientPipelinedStIdle
     ('S ('S n))
     (Header blk)
     (Point blk)
     (Tip blk)
     m
     ChainSyncClientResult
forall (n :: N).
KnownIntersectionState blk
-> MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> WithOrigin BlockNo
-> Consensus (ClientPipelinedStIdle n) blk m
requestNext
                          KnownIntersectionState blk
kis
                          MkPipelineDecision
mkPipelineDecision'
                          (Nat n -> Nat ('S ('S n))
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n)
                          Their (Tip blk)
theirTip
                          WithOrigin BlockNo
candTipBlockNo
                  )
                  (KnownIntersectionState blk
-> MkPipelineDecision
-> Nat n
-> ClientStNext
     n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall (n :: N).
KnownIntersectionState blk
-> MkPipelineDecision -> Nat n -> Consensus (ClientStNext n) blk m
handleNext KnownIntersectionState blk
kis MkPipelineDecision
mkPipelineDecision' Nat n
n')

          (Succ Nat n
n', (PipelineDecision n
Collect, MkPipelineDecision
mkPipelineDecision')) ->
              Maybe
  (m (ClientPipelinedStIdle
        ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
-> ClientStNext
     n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> ClientPipelinedStIdle
     ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CollectResponse
                  Maybe
  (m (ClientPipelinedStIdle
        ('S n) (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
forall a. Maybe a
Nothing
                  (KnownIntersectionState blk
-> MkPipelineDecision
-> Nat n
-> ClientStNext
     n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall (n :: N).
KnownIntersectionState blk
-> MkPipelineDecision -> Nat n -> Consensus (ClientStNext n) blk m
handleNext KnownIntersectionState blk
kis MkPipelineDecision
mkPipelineDecision' Nat n
n')

    handleNext ::
        KnownIntersectionState blk
     -> MkPipelineDecision
     -> Nat n
     -> Consensus (ClientStNext n) blk m
    handleNext :: forall (n :: N).
KnownIntersectionState blk
-> MkPipelineDecision -> Nat n -> Consensus (ClientStNext n) blk m
handleNext KnownIntersectionState blk
kis MkPipelineDecision
mkPipelineDecision Nat n
n =
      -- Unconditionally restart the leaky LoP bucket when receiving any
      -- message.
      ClientStNext {
        recvMsgRollForward :: Header blk
-> Tip blk
-> m (ClientPipelinedStIdle
        n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
recvMsgRollForward = \Header blk
hdr Tip blk
theirTip -> do
            (Idling m -> m ()
forall (m :: * -> *). Idling m -> m ()
idlingStop Idling m
idling m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LoPBucket m -> m ()
forall (m :: * -> *). LoPBucket m -> m ()
lbResume LoPBucket m
loPBucket)
            Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Header blk -> TraceChainSyncClientEvent blk
forall blk. Header blk -> TraceChainSyncClientEvent blk
TraceDownloadedHeader Header blk
hdr
            KnownIntersectionState blk
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
-> m (ClientPipelinedStIdle
        n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState KnownIntersectionState blk
kis (Stateful
   m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
 -> m (ClientPipelinedStIdle
         n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
-> m (ClientPipelinedStIdle
        n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall a b. (a -> b) -> a -> b
$
                MkPipelineDecision
-> Nat n
-> Header blk
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall (n :: N).
MkPipelineDecision
-> Nat n
-> Header blk
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
rollForward
                    MkPipelineDecision
mkPipelineDecision
                    Nat n
n
                    Header blk
hdr
                    (Tip blk -> Their (Tip blk)
forall a. a -> Their a
Their Tip blk
theirTip)
      ,
        recvMsgRollBackward :: Point blk
-> Tip blk
-> m (ClientPipelinedStIdle
        n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
recvMsgRollBackward = \Point blk
intersection Tip blk
theirTip -> do
            (Idling m -> m ()
forall (m :: * -> *). Idling m -> m ()
idlingStop Idling m
idling m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LoPBucket m -> m ()
forall (m :: * -> *). LoPBucket m -> m ()
lbResume LoPBucket m
loPBucket)
            let intersection' :: Point blk
                intersection' :: Point blk
intersection' = Point blk -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
intersection
            Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> TraceChainSyncClientEvent blk
forall blk. Point blk -> TraceChainSyncClientEvent blk
TraceRolledBack Point blk
intersection'
            KnownIntersectionState blk
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
-> m (ClientPipelinedStIdle
        n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState KnownIntersectionState blk
kis (Stateful
   m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
 -> m (ClientPipelinedStIdle
         n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
-> m (ClientPipelinedStIdle
        n (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
forall a b. (a -> b) -> a -> b
$
                MkPipelineDecision
-> Nat n
-> Point blk
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall (n :: N).
MkPipelineDecision
-> Nat n
-> Point blk
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
rollBackward
                    MkPipelineDecision
mkPipelineDecision
                    Nat n
n
                    Point blk
intersection'
                    (Tip blk -> Their (Tip blk)
forall a. a -> Their a
Their Tip blk
theirTip)
      }

    -- Process a new header.
    --
    -- This is also the place where we check whether their chain still
    -- intersects with ours. We have to do this in order to get a ledger state
    -- to forecast from. It is also sufficient to do this just here, and not on
    -- MsgRollBack or MsgAwaitReply as these do not induce significant work in
    -- the context of ChainSync.
    rollForward ::
        MkPipelineDecision
     -> Nat n
     -> Header blk
     -> Their (Tip blk)
     -> Stateful m blk
            (KnownIntersectionState blk)
            (ClientPipelinedStIdle n)
    rollForward :: forall (n :: N).
MkPipelineDecision
-> Nat n
-> Header blk
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
rollForward MkPipelineDecision
mkPipelineDecision Nat n
n Header blk
hdr Their (Tip blk)
theirTip =
        (KnownIntersectionState blk
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall (m :: * -> *) blk s
       (st :: * -> * -> * -> (* -> *) -> * -> *).
(s -> m (Consensus st blk m)) -> Stateful m blk s st
Stateful ((KnownIntersectionState blk
  -> m (Consensus (ClientPipelinedStIdle n) blk m))
 -> Stateful
      m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n))
-> (KnownIntersectionState blk
    -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall a b. (a -> b) -> a -> b
$ \KnownIntersectionState blk
kis -> m (Consensus (ClientPipelinedStIdle n) blk m)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a. m a -> m a
traceException (m (Consensus (ClientPipelinedStIdle n) blk m)
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> m (Consensus (ClientPipelinedStIdle n) blk m)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$ do
            arrival     <- Header blk -> m arrival
recordHeaderArrival Header blk
hdr
            arrivalTime <- getMonotonicTime

            let slotNo = Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr

            checkKnownInvalid cfgEnv dynEnv intEnv hdr

            Jumping.jgOnRollForward jumping (blockPoint hdr)
            atomically (setLatestSlot dynEnv (NotOrigin slotNo))

            checkTime cfgEnv dynEnv intEnv kis arrival slotNo >>= \case
                UpdatedIntersectionState
  blk (LedgerView (BlockProtocol blk), RelativeTime)
NoLongerIntersects ->
                    ()
-> Stateful m blk () (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState ()
                  (Stateful m blk () (ClientPipelinedStIdle n)
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful m blk () (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$ Nat n
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
-> Stateful m blk () (ClientPipelinedStIdle n)
forall s (n :: N).
NoThunks s =>
Nat n
-> Stateful m blk s (ClientPipelinedStIdle 'Z)
-> Stateful m blk s (ClientPipelinedStIdle n)
drainThePipe Nat n
n
                  (Stateful m blk () (ClientPipelinedStIdle 'Z)
 -> Stateful m blk () (ClientPipelinedStIdle n))
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
-> Stateful m blk () (ClientPipelinedStIdle n)
forall a b. (a -> b) -> a -> b
$ ConfigEnv m blk
-> DynamicEnv m blk
-> InternalEnv m blk arrival judgment
-> BlockNo
-> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
forall (m :: * -> *) blk arrival judgment.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk
-> InternalEnv m blk arrival judgment
-> BlockNo
-> (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult)
-> Stateful m blk () (ClientPipelinedStIdle 'Z)
findIntersectionTop
                        ConfigEnv m blk
cfgEnv
                        DynamicEnv m blk
dynEnv
                        InternalEnv m blk arrival judgment
intEnv
                        (KnownIntersectionState blk -> BlockNo
forall blk. KnownIntersectionState blk -> BlockNo
kBestBlockNo KnownIntersectionState blk
kis)
                        Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult
forall blk.
BlockSupportsProtocol blk =>
Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult
NoMoreIntersection

                StillIntersects (LedgerView (BlockProtocol blk)
ledgerView, RelativeTime
hdrSlotTime) KnownIntersectionState blk
kis' -> do
                    kis'' <-
                        ConfigEnv m blk
-> InternalEnv m blk arrival judgment
-> Header blk
-> RelativeTime
-> Their (Tip blk)
-> KnownIntersectionState blk
-> LedgerView (BlockProtocol blk)
-> m (KnownIntersectionState blk)
forall (m :: * -> *) blk arrival judgment.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> InternalEnv m blk arrival judgment
-> Header blk
-> RelativeTime
-> Their (Tip blk)
-> KnownIntersectionState blk
-> LedgerView (BlockProtocol blk)
-> m (KnownIntersectionState blk)
checkValid ConfigEnv m blk
cfgEnv InternalEnv m blk arrival judgment
intEnv Header blk
hdr RelativeTime
hdrSlotTime Their (Tip blk)
theirTip KnownIntersectionState blk
kis' LedgerView (BlockProtocol blk)
ledgerView
                    kis''' <- checkLoP cfgEnv dynEnv hdr kis''

                    atomically $ do
                      updateJumpInfoSTM jumping kis'''
                      setCandidate (theirFrag kis''')
                    atomically
                      $ traceWith headerMetricsTracer (slotNo, arrivalTime)

                    continueWithState kis'''
                      $ nextStep mkPipelineDecision n theirTip

    rollBackward ::
        MkPipelineDecision
     -> Nat n
     -> Point blk
     -> Their (Tip blk)
     -> Stateful m blk
          (KnownIntersectionState blk)
          (ClientPipelinedStIdle n)
    rollBackward :: forall (n :: N).
MkPipelineDecision
-> Nat n
-> Point blk
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
rollBackward MkPipelineDecision
mkPipelineDecision Nat n
n Point blk
rollBackPoint Their (Tip blk)
theirTip =
        (KnownIntersectionState blk
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall (m :: * -> *) blk s
       (st :: * -> * -> * -> (* -> *) -> * -> *).
(s -> m (Consensus st blk m)) -> Stateful m blk s st
Stateful ((KnownIntersectionState blk
  -> m (Consensus (ClientPipelinedStIdle n) blk m))
 -> Stateful
      m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n))
-> (KnownIntersectionState blk
    -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall a b. (a -> b) -> a -> b
$ \KnownIntersectionState blk
kis ->
            m (Consensus (ClientPipelinedStIdle n) blk m)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a. m a -> m a
traceException
          (m (Consensus (ClientPipelinedStIdle n) blk m)
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> m (Consensus (ClientPipelinedStIdle n) blk m)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$ let KnownIntersectionState {
                    Point blk
mostRecentIntersection :: forall blk. KnownIntersectionState blk -> Point blk
mostRecentIntersection :: Point blk
mostRecentIntersection
                  , AnchoredFragment (Header blk)
ourFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (Header blk)
ourFrag :: AnchoredFragment (Header blk)
ourFrag
                  , AnchoredFragment (HeaderWithTime blk)
theirFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (HeaderWithTime blk)
theirFrag :: AnchoredFragment (HeaderWithTime blk)
theirFrag
                  , HeaderStateHistory blk
theirHeaderStateHistory :: forall blk. KnownIntersectionState blk -> HeaderStateHistory blk
theirHeaderStateHistory :: HeaderStateHistory blk
theirHeaderStateHistory
                  , BlockNo
kBestBlockNo :: forall blk. KnownIntersectionState blk -> BlockNo
kBestBlockNo :: BlockNo
kBestBlockNo
                  } = KnownIntersectionState blk
kis
            in
            case Point blk
-> (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk)
-> Maybe
     (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk,
      Maybe (HeaderStateWithTime blk))
forall blk.
(BlockSupportsProtocol blk, HasAnnTip blk) =>
Point blk
-> (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk)
-> Maybe
     (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk,
      Maybe (HeaderStateWithTime blk))
attemptRollback
                     Point blk
rollBackPoint
                     (AnchoredFragment (HeaderWithTime blk)
theirFrag, HeaderStateHistory blk
theirHeaderStateHistory)
              of
                Maybe
  (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk,
   Maybe (HeaderStateWithTime blk))
Nothing ->
                    -- Remember that we use our current chain fragment as the
                    -- starting point for the candidate's chain. Our fragment
                    -- contained @k@ headers. At this point, the candidate
                    -- fragment might have grown to more than @k@ or rolled
                    -- back to less than @k@ headers.
                    --
                    -- But now, it rolled back to some point that is not on the
                    -- fragment, which means that it tried to roll back to some
                    -- point before one of the last @k@ headers we initially
                    -- started from. We could never switch to this fork anyway,
                    -- so just disconnect. Furthermore, our current chain might
                    -- have advanced in the meantime, so the point we would
                    -- have to roll back to might have been much further back
                    -- than @k@ blocks (> @k@ + the number of blocks we have
                    -- advanced since starting syncing).
                    --
                    -- INVARIANT: a candidate fragment contains @>=k@ headers
                    -- (unless near genesis, in which case we mean the total
                    -- number of blocks in the fragment) minus @r@ headers
                    -- where @r <= k@. This ghost variable @r@ indicates the
                    -- number of headers we temporarily rolled back. Such a
                    -- rollback must always be followed by rolling forward @s@
                    -- new headers where @s >= r@.
                    --
                    -- Thus, @k - r + s >= k@.
                    Nat n
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall (n :: N).
Nat n
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle n) blk m)
terminateAfterDrain Nat n
n
                  (ChainSyncClientResult
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> ChainSyncClientResult
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$ Point blk
-> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult
forall blk.
BlockSupportsProtocol blk =>
Point blk
-> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult
RolledBackPastIntersection
                        Point blk
rollBackPoint
                        (AnchoredFragment (Header blk) -> Our (Tip blk)
forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk) -> Our (Tip blk)
ourTipFromChain AnchoredFragment (Header blk)
ourFrag)
                        Their (Tip blk)
theirTip

                Just (AnchoredFragment (HeaderWithTime blk)
theirFrag', HeaderStateHistory blk
theirHeaderStateHistory', Maybe (HeaderStateWithTime blk)
mOldestRewound) -> do

                  Maybe (HeaderStateWithTime blk)
-> (HeaderStateWithTime blk -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (HeaderStateWithTime blk)
mOldestRewound ((HeaderStateWithTime blk -> m ()) -> m ())
-> (HeaderStateWithTime blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \HeaderStateWithTime blk
oldestRewound ->
                    HistoricityCheck m blk
-> HistoricalChainSyncMessage
-> HeaderStateWithTime blk
-> m (Either HistoricityException ())
forall (m :: * -> *) blk.
HistoricityCheck m blk
-> HistoricalChainSyncMessage
-> HeaderStateWithTime blk
-> m (Either HistoricityException ())
HistoricityCheck.judgeMessageHistoricity
                        HistoricityCheck m blk
historicityCheck
                        HistoricalChainSyncMessage
HistoricalMsgRollBackward
                        HeaderStateWithTime blk
oldestRewound m (Either HistoricityException ())
-> (Either HistoricityException () -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                      Left HistoricityException
ex  -> ChainSyncClientException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ChainSyncClientException -> m ())
-> ChainSyncClientException -> m ()
forall a b. (a -> b) -> a -> b
$ HistoricityException -> ChainSyncClientException
HistoricityError HistoricityException
ex
                      Right () -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

                  -- We just rolled back to @rollBackPoint@, either our most
                  -- recent intersection was after or at @rollBackPoint@, in
                  -- which case @rollBackPoint@ becomes the new most recent
                  -- intersection.
                  --
                  -- But if the most recent intersection was /before/
                  -- @rollBackPoint@, then the most recent intersection doesn't
                  -- change.
                  let mostRecentIntersection' :: Point blk
mostRecentIntersection' =
                          if   Point (Header blk) -> AnchoredFragment (Header blk) -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds
                                   (Point blk -> Point (Header blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
rollBackPoint)
                                   AnchoredFragment (Header blk)
ourFrag
                          then Point blk
rollBackPoint
                          else Point blk
mostRecentIntersection

                      kis' :: KnownIntersectionState blk
kis' =
                          ConsensusConfig (BlockProtocol blk)
-> KnownIntersectionState blk -> KnownIntersectionState blk
forall blk.
(HasHeader blk, HasHeader (Header blk), HasAnnTip blk,
 ConsensusProtocol (BlockProtocol blk), HasCallStack) =>
ConsensusConfig (BlockProtocol blk)
-> KnownIntersectionState blk -> KnownIntersectionState blk
assertKnownIntersectionInvariants
                              (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
                        (KnownIntersectionState blk -> KnownIntersectionState blk)
-> KnownIntersectionState blk -> KnownIntersectionState blk
forall a b. (a -> b) -> a -> b
$ KnownIntersectionState {
                              mostRecentIntersection :: Point blk
mostRecentIntersection  = Point blk
mostRecentIntersection'
                            , ourFrag :: AnchoredFragment (Header blk)
ourFrag                 = AnchoredFragment (Header blk)
ourFrag
                            , theirFrag :: AnchoredFragment (HeaderWithTime blk)
theirFrag               = AnchoredFragment (HeaderWithTime blk)
theirFrag'
                            , theirHeaderStateHistory :: HeaderStateHistory blk
theirHeaderStateHistory = HeaderStateHistory blk
theirHeaderStateHistory'
                            , BlockNo
kBestBlockNo :: BlockNo
kBestBlockNo :: BlockNo
kBestBlockNo
                            }
                  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
$ do
                    Jumping m blk -> KnownIntersectionState blk -> STM m ()
forall (m :: * -> *) blk.
Jumping m blk -> KnownIntersectionState blk -> STM m ()
updateJumpInfoSTM Jumping m blk
jumping KnownIntersectionState blk
kis'
                    AnchoredFragment (HeaderWithTime blk) -> STM m ()
setCandidate AnchoredFragment (HeaderWithTime blk)
theirFrag'
                    DynamicEnv m blk -> WithOrigin SlotNo -> STM m ()
forall (m :: * -> *) blk.
DynamicEnv m blk -> WithOrigin SlotNo -> STM m ()
setLatestSlot DynamicEnv m blk
dynEnv (Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
rollBackPoint)

                  Jumping m blk -> WithOrigin SlotNo -> m ()
forall (m :: * -> *) blk.
Jumping m blk -> WithOrigin SlotNo -> m ()
Jumping.jgOnRollBackward Jumping m blk
jumping (Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
rollBackPoint)

                  KnownIntersectionState blk
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState KnownIntersectionState blk
kis' (Stateful
   m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
 -> m (Consensus (ClientPipelinedStIdle n) blk m))
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
-> m (Consensus (ClientPipelinedStIdle n) blk m)
forall a b. (a -> b) -> a -> b
$
                      MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
forall (n :: N).
MkPipelineDecision
-> Nat n
-> Their (Tip blk)
-> Stateful
     m blk (KnownIntersectionState blk) (ClientPipelinedStIdle n)
nextStep MkPipelineDecision
mkPipelineDecision Nat n
n Their (Tip blk)
theirTip

-- | Let ChainSync jumping know about an update to the 'KnownIntersectionState'.
updateJumpInfoSTM ::
     Jumping.Jumping m blk
  -> KnownIntersectionState blk
  -> STM m ()
updateJumpInfoSTM :: forall (m :: * -> *) blk.
Jumping m blk -> KnownIntersectionState blk -> STM m ()
updateJumpInfoSTM Jumping m blk
jumping kis :: KnownIntersectionState blk
kis@KnownIntersectionState{AnchoredFragment (Header blk)
ourFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (Header blk)
ourFrag :: AnchoredFragment (Header blk)
ourFrag} =
    Jumping m blk -> JumpInfo blk -> STM m ()
forall (m :: * -> *) blk. Jumping m blk -> JumpInfo blk -> STM m ()
Jumping.jgUpdateJumpInfo Jumping m blk
jumping JumpInfo
      { jMostRecentIntersection :: Point blk
jMostRecentIntersection = KnownIntersectionState blk -> Point blk
forall blk. KnownIntersectionState blk -> Point blk
mostRecentIntersection KnownIntersectionState blk
kis
      , jOurFragment :: AnchoredFragment (Header blk)
jOurFragment = AnchoredFragment (Header blk)
ourFrag
      , jTheirFragment :: AnchoredFragment (HeaderWithTime blk)
jTheirFragment = KnownIntersectionState blk -> AnchoredFragment (HeaderWithTime blk)
forall blk.
KnownIntersectionState blk -> AnchoredFragment (HeaderWithTime blk)
theirFrag KnownIntersectionState blk
kis
      , jTheirHeaderStateHistory :: HeaderStateHistory blk
jTheirHeaderStateHistory = KnownIntersectionState blk -> HeaderStateHistory blk
forall blk. KnownIntersectionState blk -> HeaderStateHistory blk
theirHeaderStateHistory KnownIntersectionState blk
kis
      }

{-------------------------------------------------------------------------------
  Header checks
-------------------------------------------------------------------------------}

-- | Check whether 'getIsInvalidBlock' indicates that the peer's most recent
-- header indicates they are either adversarial or buggy
--
-- If the peer is sending headers quickly, the 'invalidBlockRejector' might
-- miss one. So this call is a lightweight supplement. Note that neither check
-- /must/ be 100% reliable.
checkKnownInvalid ::
  forall m blk arrival judgment.
     ( IOLike m
     , LedgerSupportsProtocol blk
     )
  => ConfigEnv m blk
  -> DynamicEnv m blk
  -> InternalEnv m blk arrival judgment
  -> Header blk
  -> m ()
checkKnownInvalid :: forall (m :: * -> *) blk arrival judgment.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk
-> InternalEnv m blk arrival judgment
-> Header blk
-> m ()
checkKnownInvalid ConfigEnv m blk
cfgEnv DynamicEnv m blk
dynEnv InternalEnv m blk arrival judgment
intEnv Header blk
hdr = case ChainHash blk
scrutinee of
    ChainHash blk
GenesisHash    -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    BlockHash HeaderHash blk
hash -> do
        isInvalidBlock <- STM m (HeaderHash blk -> Maybe (ExtValidationError blk))
-> m (HeaderHash blk -> Maybe (ExtValidationError blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (HeaderHash blk -> Maybe (ExtValidationError blk))
 -> m (HeaderHash blk -> Maybe (ExtValidationError blk)))
-> STM m (HeaderHash blk -> Maybe (ExtValidationError blk))
-> m (HeaderHash blk -> Maybe (ExtValidationError blk))
forall a b. (a -> b) -> a -> b
$ WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk))
-> HeaderHash blk -> Maybe (ExtValidationError blk)
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk))
 -> HeaderHash blk -> Maybe (ExtValidationError blk))
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
-> STM m (HeaderHash blk -> Maybe (ExtValidationError blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock
        whenJust (isInvalidBlock hash) $ \ExtValidationError blk
reason ->
            ChainSyncClientException -> m ()
forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect (ChainSyncClientException -> m ())
-> ChainSyncClientException -> m ()
forall a b. (a -> b) -> a -> b
$ Point blk
-> HeaderHash blk
-> ExtValidationError blk
-> ChainSyncClientException
forall blk.
LedgerSupportsProtocol blk =>
Point blk
-> HeaderHash blk
-> ExtValidationError blk
-> ChainSyncClientException
InvalidBlock (Header blk -> Point blk
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint Header blk
hdr) HeaderHash blk
hash ExtValidationError blk
reason
  where
    ConfigEnv {
          ChainDbView m blk
chainDbView :: forall (m :: * -> *) blk. ConfigEnv m blk -> ChainDbView m blk
chainDbView :: ChainDbView m blk
chainDbView
        , DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: forall (m :: * -> *) blk.
ConfigEnv m blk -> DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport
      } = ConfigEnv m blk
cfgEnv

    ChainDbView {
        STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock :: forall (m :: * -> *) blk.
ChainDbView m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock :: STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock
      } = ChainDbView m blk
chainDbView

    DynamicEnv {
        version :: forall (m :: * -> *) blk. DynamicEnv m blk -> NodeToNodeVersion
version = NodeToNodeVersion
_version
      } = DynamicEnv m blk
dynEnv

    InternalEnv {
        forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> forall (m' :: * -> *) a.
   MonadThrow m' =>
   ChainSyncClientException -> m' a
disconnect :: forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect
      } = InternalEnv m blk arrival judgment
intEnv

    -- When pipelining, the tip of the candidate is forgiven for being an
    -- invalid block, but not if it extends any invalid blocks.
    scrutinee :: ChainHash blk
scrutinee = case DiffusionPipeliningSupport
getDiffusionPipeliningSupport of
        DiffusionPipeliningSupport
DiffusionPipeliningOff -> HeaderHash blk -> ChainHash blk
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr)
        -- Disconnect if the parent block of `hdr` is known to be invalid.
        DiffusionPipeliningSupport
DiffusionPipeliningOn  -> Header blk -> ChainHash blk
forall blk. GetPrevHash blk => Header blk -> ChainHash blk
headerPrevHash Header blk
hdr

-- | Manage the relationships between the header's slot, arrival time, and
-- intersection with the local selection
--
-- The first step is to determine the timestamp of the slot's onset (which is
-- also returned in case of success). If the intersection with local selection
-- is much older than the header, then this may not be possible. The client will
-- block until that is no longer true. However, it will stop blocking and
-- 'exitEarly' as soon as 'NoLongerIntersects' arises.
--
-- If the slot is from the far-future, the peer is buggy, so disconnect. If
-- it's from the near-future, follow the Ouroboros Chronos rule and ignore this
-- peer until this header is no longer from the future.
--
-- Finally, the client will block on the intersection a second time, if
-- necessary, since it's possible for a ledger state to determine the slot's
-- onset's timestamp without also determining the slot's 'LedgerView'. During
-- this pause, the LoP bucket is paused. If we need to block and their fragment
-- is not preferrable to ours, we disconnect.
checkTime ::
  forall m blk arrival judgment.
     ( IOLike m
     , LedgerSupportsProtocol blk
     )
  => ConfigEnv m blk
  -> DynamicEnv m blk
  -> InternalEnv m blk arrival judgment
  -> KnownIntersectionState blk
  -> arrival
  -> SlotNo
  -> m (UpdatedIntersectionState blk (LedgerView (BlockProtocol blk), RelativeTime))
checkTime :: forall (m :: * -> *) blk arrival judgment.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk
-> InternalEnv m blk arrival judgment
-> KnownIntersectionState blk
-> arrival
-> SlotNo
-> m (UpdatedIntersectionState
        blk (LedgerView (BlockProtocol blk), RelativeTime))
checkTime ConfigEnv m blk
cfgEnv DynamicEnv m blk
dynEnv InternalEnv m blk arrival judgment
intEnv =
    \KnownIntersectionState blk
kis arrival
arrival SlotNo
slotNo -> m (UpdatedIntersectionState
     blk (LedgerView (BlockProtocol blk), RelativeTime))
-> m (UpdatedIntersectionState
        blk (LedgerView (BlockProtocol blk), RelativeTime))
forall a. m a -> m a
pauseBucket (m (UpdatedIntersectionState
      blk (LedgerView (BlockProtocol blk), RelativeTime))
 -> m (UpdatedIntersectionState
         blk (LedgerView (BlockProtocol blk), RelativeTime)))
-> m (UpdatedIntersectionState
        blk (LedgerView (BlockProtocol blk), RelativeTime))
-> m (UpdatedIntersectionState
        blk (LedgerView (BlockProtocol blk), RelativeTime))
forall a b. (a -> b) -> a -> b
$ WithEarlyExit
  m (Intersects blk (LedgerView (BlockProtocol blk), RelativeTime))
-> m (UpdatedIntersectionState
        blk (LedgerView (BlockProtocol blk), RelativeTime))
forall (m :: * -> *) blk a.
Monad m =>
WithEarlyExit m (Intersects blk a)
-> m (UpdatedIntersectionState blk a)
castEarlyExitIntersects (WithEarlyExit
   m (Intersects blk (LedgerView (BlockProtocol blk), RelativeTime))
 -> m (UpdatedIntersectionState
         blk (LedgerView (BlockProtocol blk), RelativeTime)))
-> WithEarlyExit
     m (Intersects blk (LedgerView (BlockProtocol blk), RelativeTime))
-> m (UpdatedIntersectionState
        blk (LedgerView (BlockProtocol blk), RelativeTime))
forall a b. (a -> b) -> a -> b
$ do
        Intersects kis2 (lst, slotTime) <- KnownIntersectionState blk
-> arrival
-> WithEarlyExit
     m (Intersects blk (LedgerState blk EmptyMK, RelativeTime))
checkArrivalTime KnownIntersectionState blk
kis arrival
arrival
        Intersects kis3 ledgerView      <- case projectLedgerView slotNo lst of
            Just LedgerView (BlockProtocol blk)
ledgerView -> Intersects blk (LedgerView (BlockProtocol blk))
-> WithEarlyExit
     m (Intersects blk (LedgerView (BlockProtocol blk)))
forall a. a -> WithEarlyExit m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Intersects blk (LedgerView (BlockProtocol blk))
 -> WithEarlyExit
      m (Intersects blk (LedgerView (BlockProtocol blk))))
-> Intersects blk (LedgerView (BlockProtocol blk))
-> WithEarlyExit
     m (Intersects blk (LedgerView (BlockProtocol blk)))
forall a b. (a -> b) -> a -> b
$ KnownIntersectionState blk
-> LedgerView (BlockProtocol blk)
-> Intersects blk (LedgerView (BlockProtocol blk))
forall blk a. KnownIntersectionState blk -> a -> Intersects blk a
Intersects KnownIntersectionState blk
kis2 LedgerView (BlockProtocol blk)
ledgerView
            Maybe (LedgerView (BlockProtocol blk))
Nothing         -> do
              m () -> WithEarlyExit m ()
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
EarlyExit.lift (m () -> WithEarlyExit m ()) -> m () -> WithEarlyExit m ()
forall a b. (a -> b) -> a -> b
$
                  Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ConfigEnv m blk -> Tracer m (TraceChainSyncClientEvent blk)
forall (m :: * -> *) blk.
ConfigEnv m blk -> Tracer m (TraceChainSyncClientEvent blk)
tracer ConfigEnv m blk
cfgEnv)
                (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> TraceChainSyncClientEvent blk
forall blk. SlotNo -> TraceChainSyncClientEvent blk
TraceWaitingBeyondForecastHorizon SlotNo
slotNo
              res <- KnownIntersectionState blk
-> (LedgerState blk EmptyMK
    -> Maybe (LedgerView (BlockProtocol blk)))
-> WithEarlyExit
     m (Intersects blk (LedgerView (BlockProtocol blk)))
forall a.
KnownIntersectionState blk
-> (LedgerState blk EmptyMK -> Maybe a)
-> WithEarlyExit m (Intersects blk a)
readLedgerState KnownIntersectionState blk
kis2 (SlotNo
-> LedgerState blk EmptyMK
-> Maybe (LedgerView (BlockProtocol blk))
projectLedgerView SlotNo
slotNo)
              EarlyExit.lift $
                  traceWith (tracer cfgEnv)
                $ TraceAccessingForecastHorizon slotNo
              pure res
        pure $ Intersects kis3 (ledgerView, slotTime)
  where
    ConfigEnv {
        TopLevelConfig blk
cfg :: forall (m :: * -> *) blk. ConfigEnv m blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
      , ChainDbView m blk
chainDbView :: forall (m :: * -> *) blk. ConfigEnv m blk -> ChainDbView m blk
chainDbView :: ChainDbView m blk
chainDbView
      } = ConfigEnv m blk
cfgEnv

    ChainDbView {
        Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
getPastLedger :: forall (m :: * -> *) blk.
ChainDbView m blk
-> Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
getPastLedger :: Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
getPastLedger
      } = ChainDbView m blk
chainDbView

    InternalEnv {
        forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> forall (m' :: * -> *) a.
   MonadThrow m' =>
   ChainSyncClientException -> m' a
disconnect :: forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect
      , HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck :: HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck
      , KnownIntersectionState blk
-> STM m (UpdatedIntersectionState blk ())
intersectsWithCurrentChain :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> KnownIntersectionState blk
-> STM m (UpdatedIntersectionState blk ())
intersectsWithCurrentChain :: KnownIntersectionState blk
-> STM m (UpdatedIntersectionState blk ())
intersectsWithCurrentChain
      } = InternalEnv m blk arrival judgment
intEnv

    InFutureCheck.HeaderInFutureCheck {
        judgment -> m (Except HeaderArrivalException RelativeTime)
handleHeaderArrival :: judgment -> m (Except HeaderArrivalException RelativeTime)
handleHeaderArrival :: forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> judgment -> m (Except HeaderArrivalException RelativeTime)
handleHeaderArrival
      , LedgerConfig blk
-> LedgerState blk EmptyMK
-> arrival
-> Except PastHorizonException judgment
judgeHeaderArrival :: LedgerConfig blk
-> LedgerState blk EmptyMK
-> arrival
-> Except PastHorizonException judgment
judgeHeaderArrival :: forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> LedgerConfig blk
-> LedgerState blk EmptyMK
-> arrival
-> Except PastHorizonException judgment
judgeHeaderArrival
      } = HeaderInFutureCheck m blk arrival judgment
headerInFutureCheck

    -- Determine whether the header is from the future, and handle that fact if
    -- so. Also return the ledger state used for the determination.
    --
    -- Relies on 'readLedgerState'.
    checkArrivalTime ::
         KnownIntersectionState blk
      -> arrival
      -> WithEarlyExit m (Intersects blk (LedgerState blk EmptyMK, RelativeTime))
    checkArrivalTime :: KnownIntersectionState blk
-> arrival
-> WithEarlyExit
     m (Intersects blk (LedgerState blk EmptyMK, RelativeTime))
checkArrivalTime KnownIntersectionState blk
kis arrival
arrival = do
        Intersects kis' (lst, judgment) <- do
            KnownIntersectionState blk
-> (LedgerState blk EmptyMK
    -> Maybe (LedgerState blk EmptyMK, judgment))
-> WithEarlyExit
     m (Intersects blk (LedgerState blk EmptyMK, judgment))
forall a.
KnownIntersectionState blk
-> (LedgerState blk EmptyMK -> Maybe a)
-> WithEarlyExit m (Intersects blk a)
readLedgerState KnownIntersectionState blk
kis ((LedgerState blk EmptyMK
  -> Maybe (LedgerState blk EmptyMK, judgment))
 -> WithEarlyExit
      m (Intersects blk (LedgerState blk EmptyMK, judgment)))
-> (LedgerState blk EmptyMK
    -> Maybe (LedgerState blk EmptyMK, judgment))
-> WithEarlyExit
     m (Intersects blk (LedgerState blk EmptyMK, judgment))
forall a b. (a -> b) -> a -> b
$ \LedgerState blk EmptyMK
lst ->
                case   Except PastHorizonException judgment
-> Either PastHorizonException judgment
forall e a. Except e a -> Either e a
runExcept
                     (Except PastHorizonException judgment
 -> Either PastHorizonException judgment)
-> Except PastHorizonException judgment
-> Either PastHorizonException judgment
forall a b. (a -> b) -> a -> b
$ LedgerConfig blk
-> LedgerState blk EmptyMK
-> arrival
-> Except PastHorizonException judgment
judgeHeaderArrival (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg) LedgerState blk EmptyMK
lst arrival
arrival
                  of
                    Left PastHorizon{} -> Maybe (LedgerState blk EmptyMK, judgment)
forall a. Maybe a
Nothing
                    Right judgment
judgment     -> (LedgerState blk EmptyMK, judgment)
-> Maybe (LedgerState blk EmptyMK, judgment)
forall a. a -> Maybe a
Just (LedgerState blk EmptyMK
lst, judgment
judgment)

        -- For example, throw an exception if the header is from the far
        -- future.
        EarlyExit.lift $ handleHeaderArrival judgment <&> runExcept >>= \case
            Left HeaderArrivalException
exn       -> ChainSyncClientException
-> m (Intersects blk (LedgerState blk EmptyMK, RelativeTime))
forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect (HeaderArrivalException -> ChainSyncClientException
InFutureHeaderExceedsClockSkew HeaderArrivalException
exn)
            Right RelativeTime
slotTime -> Intersects blk (LedgerState blk EmptyMK, RelativeTime)
-> m (Intersects blk (LedgerState blk EmptyMK, RelativeTime))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Intersects blk (LedgerState blk EmptyMK, RelativeTime)
 -> m (Intersects blk (LedgerState blk EmptyMK, RelativeTime)))
-> Intersects blk (LedgerState blk EmptyMK, RelativeTime)
-> m (Intersects blk (LedgerState blk EmptyMK, RelativeTime))
forall a b. (a -> b) -> a -> b
$ KnownIntersectionState blk
-> (LedgerState blk EmptyMK, RelativeTime)
-> Intersects blk (LedgerState blk EmptyMK, RelativeTime)
forall blk a. KnownIntersectionState blk -> a -> Intersects blk a
Intersects KnownIntersectionState blk
kis' (LedgerState blk EmptyMK
lst, RelativeTime
slotTime)

    -- Block until the the ledger state at the intersection with the local
    -- selection returns 'Just'.
    --
    -- Exits early if the intersection no longer exists.
    readLedgerState ::
      forall a.
         KnownIntersectionState blk
      -> (LedgerState blk EmptyMK -> Maybe a)
      -> WithEarlyExit m (Intersects blk a)
    readLedgerState :: forall a.
KnownIntersectionState blk
-> (LedgerState blk EmptyMK -> Maybe a)
-> WithEarlyExit m (Intersects blk a)
readLedgerState KnownIntersectionState blk
kis LedgerState blk EmptyMK -> Maybe a
prj = m (WithEarlyExit m (Intersects blk a))
-> WithEarlyExit m (Intersects blk a)
forall (m :: * -> *) x.
Monad m =>
m (WithEarlyExit m x) -> WithEarlyExit m x
castM (m (WithEarlyExit m (Intersects blk a))
 -> WithEarlyExit m (Intersects blk a))
-> m (WithEarlyExit m (Intersects blk a))
-> WithEarlyExit m (Intersects blk a)
forall a b. (a -> b) -> a -> b
$ KnownIntersectionState blk
-> (LedgerState blk EmptyMK -> Maybe a)
-> m (WithEarlyExit m (Intersects blk a))
forall a.
KnownIntersectionState blk
-> (LedgerState blk EmptyMK -> Maybe a)
-> m (WithEarlyExit m (Intersects blk a))
readLedgerStateHelper KnownIntersectionState blk
kis LedgerState blk EmptyMK -> Maybe a
prj

    readLedgerStateHelper ::
      forall a.
         KnownIntersectionState blk
      -> (LedgerState blk EmptyMK -> Maybe a)
      -> m (WithEarlyExit m (Intersects blk a))
    readLedgerStateHelper :: forall a.
KnownIntersectionState blk
-> (LedgerState blk EmptyMK -> Maybe a)
-> m (WithEarlyExit m (Intersects blk a))
readLedgerStateHelper KnownIntersectionState blk
kis LedgerState blk EmptyMK -> Maybe a
prj = STM m (WithEarlyExit m (Intersects blk a))
-> m (WithEarlyExit m (Intersects blk a))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithEarlyExit m (Intersects blk a))
 -> m (WithEarlyExit m (Intersects blk a)))
-> STM m (WithEarlyExit m (Intersects blk a))
-> m (WithEarlyExit m (Intersects blk a))
forall a b. (a -> b) -> a -> b
$ do
        -- We must first find the most recent intersection with the current
        -- chain. Note that this is cheap when the chain and candidate haven't
        -- changed.
        KnownIntersectionState blk
-> STM m (UpdatedIntersectionState blk ())
intersectsWithCurrentChain KnownIntersectionState blk
kis STM m (UpdatedIntersectionState blk ())
-> (UpdatedIntersectionState blk ()
    -> STM m (WithEarlyExit m (Intersects blk a)))
-> STM m (WithEarlyExit m (Intersects blk a))
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
            UpdatedIntersectionState blk ()
NoLongerIntersects      -> WithEarlyExit m (Intersects blk a)
-> STM m (WithEarlyExit m (Intersects blk a))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return WithEarlyExit m (Intersects blk a)
forall (m :: * -> *) a. Applicative m => WithEarlyExit m a
exitEarly
            StillIntersects () KnownIntersectionState blk
kis' -> do
                let KnownIntersectionState {
                        Point blk
mostRecentIntersection :: forall blk. KnownIntersectionState blk -> Point blk
mostRecentIntersection :: Point blk
mostRecentIntersection
                      } = KnownIntersectionState blk
kis'
                lst <-
                    (Maybe (ExtLedgerState blk EmptyMK) -> LedgerState blk EmptyMK)
-> STM m (Maybe (ExtLedgerState blk EmptyMK))
-> STM m (LedgerState blk EmptyMK)
forall a b. (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                      (LedgerState blk EmptyMK
-> (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK)
-> Maybe (ExtLedgerState blk EmptyMK)
-> LedgerState blk EmptyMK
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                           (String -> LedgerState blk EmptyMK
forall a. HasCallStack => String -> a
error (String -> LedgerState blk EmptyMK)
-> String -> LedgerState blk EmptyMK
forall a b. (a -> b) -> a -> b
$
                                 String
"intersection not within last k blocks: "
                              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Point blk -> String
forall a. Show a => a -> String
show Point blk
mostRecentIntersection
                           )
                           ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState
                      )
                  (STM m (Maybe (ExtLedgerState blk EmptyMK))
 -> STM m (LedgerState blk EmptyMK))
-> STM m (Maybe (ExtLedgerState blk EmptyMK))
-> STM m (LedgerState blk EmptyMK)
forall a b. (a -> b) -> a -> b
$ Point blk -> STM m (Maybe (ExtLedgerState blk EmptyMK))
getPastLedger Point blk
mostRecentIntersection
                case prj lst of
                    Maybe a
Nothing         -> do
                        KnownIntersectionState blk -> STM m ()
checkPreferTheirsOverOurs KnownIntersectionState blk
kis'
                        STM m (WithEarlyExit m (Intersects blk a))
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                    Just a
ledgerView ->
                        WithEarlyExit m (Intersects blk a)
-> STM m (WithEarlyExit m (Intersects blk a))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (WithEarlyExit m (Intersects blk a)
 -> STM m (WithEarlyExit m (Intersects blk a)))
-> WithEarlyExit m (Intersects blk a)
-> STM m (WithEarlyExit m (Intersects blk a))
forall a b. (a -> b) -> a -> b
$ Intersects blk a -> WithEarlyExit m (Intersects blk a)
forall a. a -> WithEarlyExit m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Intersects blk a -> WithEarlyExit m (Intersects blk a))
-> Intersects blk a -> WithEarlyExit m (Intersects blk a)
forall a b. (a -> b) -> a -> b
$ KnownIntersectionState blk -> a -> Intersects blk a
forall blk a. KnownIntersectionState blk -> a -> Intersects blk a
Intersects KnownIntersectionState blk
kis' a
ledgerView

    -- Note [Candidate comparing beyond the forecast horizon]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    --
    -- When a header is beyond the forecast horizon and their fragment is not
    -- preferrable to our selection (ourFrag), then we disconnect, as we will
    -- never end up selecting it.
    --
    -- In the context of Genesis, one can think of the candidate losing a
    -- density comparison against the selection. See the Genesis documentation
    -- for why this check is necessary.
    --
    -- In particular, this means that we will disconnect from peers who offer us
    -- a chain containing a slot gap larger than a forecast window.
    checkPreferTheirsOverOurs :: KnownIntersectionState blk -> STM m ()
    checkPreferTheirsOverOurs :: KnownIntersectionState blk -> STM m ()
checkPreferTheirsOverOurs KnownIntersectionState blk
kis
      | -- Precondition is fulfilled as ourFrag and theirFrag intersect by
        -- construction.
        BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (HeaderWithTime blk)
-> Bool
forall blk (h :: * -> *) (h' :: * -> *).
(BlockSupportsProtocol blk, HasCallStack, GetHeader1 h,
 GetHeader1 h', HeaderHash (h blk) ~ HeaderHash (h' blk),
 HasHeader (h blk), HasHeader (h' blk)) =>
BlockConfig blk
-> AnchoredFragment (h blk) -> AnchoredFragment (h' blk) -> Bool
preferAnchoredCandidate (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg) AnchoredFragment (Header blk)
ourFrag AnchoredFragment (HeaderWithTime blk)
theirFrag
      = () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise
      = ChainSyncClientException -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (ChainSyncClientException -> STM m ())
-> ChainSyncClientException -> STM m ()
forall a b. (a -> b) -> a -> b
$ Point blk
-> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientException
forall blk.
BlockSupportsProtocol blk =>
Point blk
-> Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientException
CandidateTooSparse
            Point blk
mostRecentIntersection
            (AnchoredFragment (Header blk) -> Our (Tip blk)
forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk) -> Our (Tip blk)
ourTipFromChain AnchoredFragment (Header blk)
ourFrag)
            (AnchoredFragment (HeaderWithTime blk) -> Their (Tip blk)
forall blk.
HasHeader (HeaderWithTime blk) =>
AnchoredFragment (HeaderWithTime blk) -> Their (Tip blk)
theirTipFromChain AnchoredFragment (HeaderWithTime blk)
theirFrag)
      where
        KnownIntersectionState {
            Point blk
mostRecentIntersection :: forall blk. KnownIntersectionState blk -> Point blk
mostRecentIntersection :: Point blk
mostRecentIntersection
          , AnchoredFragment (Header blk)
ourFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (Header blk)
ourFrag :: AnchoredFragment (Header blk)
ourFrag
          , AnchoredFragment (HeaderWithTime blk)
theirFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (HeaderWithTime blk)
theirFrag :: AnchoredFragment (HeaderWithTime blk)
theirFrag
          } = KnownIntersectionState blk
kis

    -- Returns 'Nothing' if the ledger state cannot forecast the ledger view
    -- that far into the future.
    projectLedgerView ::
         SlotNo
      -> LedgerState blk EmptyMK
      -> Maybe (LedgerView (BlockProtocol blk))
    projectLedgerView :: SlotNo
-> LedgerState blk EmptyMK
-> Maybe (LedgerView (BlockProtocol blk))
projectLedgerView SlotNo
slot LedgerState blk EmptyMK
lst =
        let forecast :: Forecast (LedgerView (BlockProtocol blk))
forecast = LedgerConfig blk
-> LedgerState blk EmptyMK
-> Forecast (LedgerView (BlockProtocol blk))
forall blk (mk :: MapKind).
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
forall (mk :: MapKind).
HasCallStack =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg) LedgerState blk EmptyMK
lst
              -- TODO cache this in the KnownIntersectionState? Or even in the
              -- LedgerDB?
        in
        case Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk))
forall e a. Except e a -> Either e a
runExcept (Except OutsideForecastRange (LedgerView (BlockProtocol blk))
 -> Either OutsideForecastRange (LedgerView (BlockProtocol blk)))
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a b. (a -> b) -> a -> b
$ Forecast (LedgerView (BlockProtocol blk))
-> SlotNo
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor Forecast (LedgerView (BlockProtocol blk))
forecast SlotNo
slot of
            Right LedgerView (BlockProtocol blk)
ledgerView            -> LedgerView (BlockProtocol blk)
-> Maybe (LedgerView (BlockProtocol blk))
forall a. a -> Maybe a
Just LedgerView (BlockProtocol blk)
ledgerView
            Left OutsideForecastRange{} ->
                -- The header is too far ahead of the intersection point with
                -- our current chain. We have to wait until our chain and the
                -- intersection have advanced far enough. This will wait on
                -- changes to the current chain via the call to
                -- 'intersectsWithCurrentChain' before it.
                Maybe (LedgerView (BlockProtocol blk))
forall a. Maybe a
Nothing

    -- Pause the LoP bucket for the entire duration of 'checkTime'. It will
    -- either execute very fast, or it will block on the time translation or
    -- forecast horizon, waiting for our selection to advance. During this
    -- period, we should not leak tokens as our peer is not responsible for this
    -- waiting time.
    pauseBucket :: m a -> m a
    pauseBucket :: forall a. m a -> m a
pauseBucket =
        m () -> m () -> m a -> m a
forall a b c. m a -> m b -> m c -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> m b -> m c -> m c
bracket_
          (LoPBucket m -> m ()
forall (m :: * -> *). LoPBucket m -> m ()
lbPause (DynamicEnv m blk -> LoPBucket m
forall (m :: * -> *) blk. DynamicEnv m blk -> LoPBucket m
loPBucket DynamicEnv m blk
dynEnv))
          (LoPBucket m -> m ()
forall (m :: * -> *). LoPBucket m -> m ()
lbResume (DynamicEnv m blk -> LoPBucket m
forall (m :: * -> *) blk. DynamicEnv m blk -> LoPBucket m
loPBucket DynamicEnv m blk
dynEnv))

-- | Update the 'KnownIntersectionState' according to the header, if it's valid
--
-- Crucially: disconnects if it isn't.
checkValid ::
  forall m blk arrival judgment.
     ( IOLike m
     , LedgerSupportsProtocol blk
     )
  => ConfigEnv m blk
  -> InternalEnv m blk arrival judgment
  -> Header blk
  -> RelativeTime -- ^ onset of the header's slot
  -> Their (Tip blk)
  -> KnownIntersectionState blk
  -> LedgerView (BlockProtocol blk)
  -> m (KnownIntersectionState blk)
checkValid :: forall (m :: * -> *) blk arrival judgment.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> InternalEnv m blk arrival judgment
-> Header blk
-> RelativeTime
-> Their (Tip blk)
-> KnownIntersectionState blk
-> LedgerView (BlockProtocol blk)
-> m (KnownIntersectionState blk)
checkValid ConfigEnv m blk
cfgEnv InternalEnv m blk arrival judgment
intEnv Header blk
hdr RelativeTime
hdrSlotTime Their (Tip blk)
theirTip KnownIntersectionState blk
kis LedgerView (BlockProtocol blk)
ledgerView = do
    let KnownIntersectionState {
            Point blk
mostRecentIntersection :: forall blk. KnownIntersectionState blk -> Point blk
mostRecentIntersection :: Point blk
mostRecentIntersection
          , AnchoredFragment (Header blk)
ourFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (Header blk)
ourFrag :: AnchoredFragment (Header blk)
ourFrag
          , AnchoredFragment (HeaderWithTime blk)
theirFrag :: forall blk.
KnownIntersectionState blk -> AnchoredFragment (HeaderWithTime blk)
theirFrag :: AnchoredFragment (HeaderWithTime blk)
theirFrag
          , HeaderStateHistory blk
theirHeaderStateHistory :: forall blk. KnownIntersectionState blk -> HeaderStateHistory blk
theirHeaderStateHistory :: HeaderStateHistory blk
theirHeaderStateHistory
          , BlockNo
kBestBlockNo :: forall blk. KnownIntersectionState blk -> BlockNo
kBestBlockNo :: BlockNo
kBestBlockNo
          } = KnownIntersectionState blk
kis

    let hdrPoint :: Point blk
hdrPoint = Header blk -> Point blk
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint Header blk
hdr

    -- Validate header
    theirHeaderStateHistory' <-
        case   Except (HeaderError blk) (HeaderStateHistory blk)
-> Either (HeaderError blk) (HeaderStateHistory blk)
forall e a. Except e a -> Either e a
runExcept
             (Except (HeaderError blk) (HeaderStateHistory blk)
 -> Either (HeaderError blk) (HeaderStateHistory blk))
-> Except (HeaderError blk) (HeaderStateHistory blk)
-> Either (HeaderError blk) (HeaderStateHistory blk)
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> RelativeTime
-> HeaderStateHistory blk
-> Except (HeaderError blk) (HeaderStateHistory blk)
forall blk.
(BlockSupportsProtocol blk, ValidateEnvelope blk) =>
TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> RelativeTime
-> HeaderStateHistory blk
-> Except (HeaderError blk) (HeaderStateHistory blk)
validateHeader TopLevelConfig blk
cfg LedgerView (BlockProtocol blk)
ledgerView Header blk
hdr RelativeTime
hdrSlotTime HeaderStateHistory blk
theirHeaderStateHistory
          of
            Right HeaderStateHistory blk
theirHeaderStateHistory' -> HeaderStateHistory blk -> m (HeaderStateHistory blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderStateHistory blk
theirHeaderStateHistory'
            Left  HeaderError blk
vErr ->
                ChainSyncClientException -> m (HeaderStateHistory blk)
forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect
              (ChainSyncClientException -> m (HeaderStateHistory blk))
-> ChainSyncClientException -> m (HeaderStateHistory blk)
forall a b. (a -> b) -> a -> b
$ Point blk
-> HeaderError blk
-> Our (Tip blk)
-> Their (Tip blk)
-> ChainSyncClientException
forall blk.
(BlockSupportsProtocol blk, ValidateEnvelope blk) =>
Point blk
-> HeaderError blk
-> Our (Tip blk)
-> Their (Tip blk)
-> ChainSyncClientException
HeaderError Point blk
hdrPoint HeaderError blk
vErr (AnchoredFragment (Header blk) -> Our (Tip blk)
forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk) -> Our (Tip blk)
ourTipFromChain AnchoredFragment (Header blk)
ourFrag) Their (Tip blk)
theirTip

    let
        validatedHdr = HeaderWithTime { hwtHeader :: Header blk
hwtHeader           = Header blk
hdr
                                      , hwtSlotRelativeTime :: RelativeTime
hwtSlotRelativeTime = RelativeTime
hdrSlotTime
                                      }
        theirFrag' = AnchoredFragment (HeaderWithTime blk)
theirFrag AnchoredFragment (HeaderWithTime blk)
-> HeaderWithTime blk -> AnchoredFragment (HeaderWithTime blk)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
:> HeaderWithTime blk
validatedHdr
        -- Advance the most recent intersection if we have the same
        -- header on our fragment too. This is cheaper than recomputing
        -- the intersection from scratch.
        mostRecentIntersection'
          | Just Header blk
ourSuccessor <-
                Point (Header blk)
-> AnchoredFragment (Header blk) -> Maybe (Header blk)
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Maybe block
AF.successorBlock (Point blk -> Point (Header blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
mostRecentIntersection) AnchoredFragment (Header blk)
ourFrag
          , Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
ourSuccessor HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr
          = Header blk -> Point blk
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint Header blk
hdr
          | Bool
otherwise
          = Point blk
mostRecentIntersection

    traceWith (tracer cfgEnv) $ TraceValidatedHeader hdr

    pure
      $ assertKnownIntersectionInvariants (configConsensus cfg)
      $ KnownIntersectionState {
            mostRecentIntersection  = mostRecentIntersection'
          , ourFrag                 = ourFrag
          , theirFrag               = theirFrag'
          , theirHeaderStateHistory = theirHeaderStateHistory'
          , kBestBlockNo
          }
  where
    ConfigEnv {
        TopLevelConfig blk
cfg :: forall (m :: * -> *) blk. ConfigEnv m blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
      } = ConfigEnv m blk
cfgEnv

    InternalEnv {
        forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect :: forall (m :: * -> *) blk arrival judgment.
InternalEnv m blk arrival judgment
-> forall (m' :: * -> *) a.
   MonadThrow m' =>
   ChainSyncClientException -> m' a
disconnect :: forall (m' :: * -> *) a.
MonadThrow m' =>
ChainSyncClientException -> m' a
disconnect
      } = InternalEnv m blk arrival judgment
intEnv

-- | Check the limit on patience. If the block number of the new header is
-- better than anything (valid) we have seen from this peer so far, we add a
-- token to their leaky bucket and we remember this new record. Has to happen
-- only after validation of the block.
checkLoP ::
  forall m blk.
   ( IOLike m
   , HasHeader (Header blk) )
  => ConfigEnv m blk
  -> DynamicEnv m blk
  -> Header blk
  -> KnownIntersectionState blk
  -> m (KnownIntersectionState blk)
checkLoP :: forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk)) =>
ConfigEnv m blk
-> DynamicEnv m blk
-> Header blk
-> KnownIntersectionState blk
-> m (KnownIntersectionState blk)
checkLoP ConfigEnv{Tracer m (TraceChainSyncClientEvent blk)
tracer :: forall (m :: * -> *) blk.
ConfigEnv m blk -> Tracer m (TraceChainSyncClientEvent blk)
tracer :: Tracer m (TraceChainSyncClientEvent blk)
tracer} DynamicEnv{LoPBucket m
loPBucket :: forall (m :: * -> *) blk. DynamicEnv m blk -> LoPBucket m
loPBucket :: LoPBucket m
loPBucket} Header blk
hdr kis :: KnownIntersectionState blk
kis@KnownIntersectionState{BlockNo
kBestBlockNo :: forall blk. KnownIntersectionState blk -> BlockNo
kBestBlockNo :: BlockNo
kBestBlockNo} =
  if Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr BlockNo -> BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
> BlockNo
kBestBlockNo
    then do LoPBucket m -> m ()
forall (m :: * -> *). LoPBucket m -> m ()
lbGrantToken LoPBucket m
loPBucket
            Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Header blk -> BlockNo -> TraceChainSyncClientEvent blk
forall blk.
Bool -> Header blk -> BlockNo -> TraceChainSyncClientEvent blk
TraceGaveLoPToken Bool
True Header blk
hdr BlockNo
kBestBlockNo
            KnownIntersectionState blk -> m (KnownIntersectionState blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KnownIntersectionState blk -> m (KnownIntersectionState blk))
-> KnownIntersectionState blk -> m (KnownIntersectionState blk)
forall a b. (a -> b) -> a -> b
$ KnownIntersectionState blk
kis{kBestBlockNo = blockNo hdr}
    else do Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Header blk -> BlockNo -> TraceChainSyncClientEvent blk
forall blk.
Bool -> Header blk -> BlockNo -> TraceChainSyncClientEvent blk
TraceGaveLoPToken Bool
False Header blk
hdr BlockNo
kBestBlockNo
            KnownIntersectionState blk -> m (KnownIntersectionState blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KnownIntersectionState blk
kis

{-------------------------------------------------------------------------------
  Utilities used in the *top functions
-------------------------------------------------------------------------------}

data UpdatedIntersectionState blk a =
    NoLongerIntersects
    -- ^ The local selection has changed such that 'ourFrag' no longer
    -- intersects 'theirFrag'
    --
    -- (In general, the intersection could also be lost because of messages
    -- they sent, but that's handled elsewhere, not involving this data type.)
  |
    StillIntersects a !(KnownIntersectionState blk)

data Intersects blk a =
    Intersects
        (KnownIntersectionState blk)
        a

castEarlyExitIntersects ::
     Monad m
  => WithEarlyExit m (Intersects blk a)
  -> m (UpdatedIntersectionState blk a)
castEarlyExitIntersects :: forall (m :: * -> *) blk a.
Monad m =>
WithEarlyExit m (Intersects blk a)
-> m (UpdatedIntersectionState blk a)
castEarlyExitIntersects =
    (Maybe (Intersects blk a) -> UpdatedIntersectionState blk a)
-> m (Maybe (Intersects blk a))
-> m (UpdatedIntersectionState blk a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Intersects blk a) -> UpdatedIntersectionState blk a
forall {blk} {a}.
Maybe (Intersects blk a) -> UpdatedIntersectionState blk a
cnv (m (Maybe (Intersects blk a))
 -> m (UpdatedIntersectionState blk a))
-> (WithEarlyExit m (Intersects blk a)
    -> m (Maybe (Intersects blk a)))
-> WithEarlyExit m (Intersects blk a)
-> m (UpdatedIntersectionState blk a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithEarlyExit m (Intersects blk a) -> m (Maybe (Intersects blk a))
forall (m :: * -> *) a. WithEarlyExit m a -> m (Maybe a)
EarlyExit.withEarlyExit
  where
    cnv :: Maybe (Intersects blk a) -> UpdatedIntersectionState blk a
cnv = \case
        Maybe (Intersects blk a)
Nothing                 -> UpdatedIntersectionState blk a
forall blk a. UpdatedIntersectionState blk a
NoLongerIntersects
        Just (Intersects KnownIntersectionState blk
kis a
a) -> a -> KnownIntersectionState blk -> UpdatedIntersectionState blk a
forall blk a.
a -> KnownIntersectionState blk -> UpdatedIntersectionState blk a
StillIntersects a
a KnownIntersectionState blk
kis

-- | Recent offsets
--
-- These offsets are used to find an intersection point between our chain
-- and the upstream node's. We use the fibonacci sequence to try blocks
-- closer to our tip, and fewer blocks further down the chain. It is
-- important that this sequence constains at least a point @k@ back: if no
-- intersection can be found at most @k@ back, then this is not a peer
-- that we can sync with (since we will never roll back more than @k).
--
-- For @k = 2160@, this evaluates to
--
-- > [0,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2160]
--
-- For @k = 5@ (during testing), this evaluates to
--
-- > [0,1,2,3,5]
--
-- In case the fragment contains less than @k@ blocks, we use the length
-- of the fragment as @k@. This ensures that the oldest rollback point is
-- selected.
mkOffsets :: SecurityParam -> Word64 -> [Word64]
mkOffsets :: SecurityParam -> Word64 -> [Word64]
mkOffsets (SecurityParam NonZero Word64
k) Word64
maxOffset =
    [Word64
0] [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ (Word64 -> Bool) -> [Word64] -> [Word64]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
l) [Word64 -> Word64
fib Word64
n | Word64
n <- [Word64
2..]] [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ [Word64
l]
  where
    l :: Word64
l = NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
`min` Word64
maxOffset

ourTipFromChain ::
     HasHeader (Header blk)
  => AnchoredFragment (Header blk)
  -> Our (Tip blk)
ourTipFromChain :: forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk) -> Our (Tip blk)
ourTipFromChain = Tip blk -> Our (Tip blk)
forall a. a -> Our a
Our (Tip blk -> Our (Tip blk))
-> (AnchoredFragment (Header blk) -> Tip blk)
-> AnchoredFragment (Header blk)
-> Our (Tip blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor (Header blk) -> Tip blk
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip (Anchor (Header blk) -> Tip blk)
-> (AnchoredFragment (Header blk) -> Anchor (Header blk))
-> AnchoredFragment (Header blk)
-> Tip blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AF.headAnchor

theirTipFromChain ::
     HasHeader (HeaderWithTime blk)
  => AnchoredFragment (HeaderWithTime blk)
  -> Their (Tip blk)
theirTipFromChain :: forall blk.
HasHeader (HeaderWithTime blk) =>
AnchoredFragment (HeaderWithTime blk) -> Their (Tip blk)
theirTipFromChain = Tip blk -> Their (Tip blk)
forall a. a -> Their a
Their (Tip blk -> Their (Tip blk))
-> (AnchoredFragment (HeaderWithTime blk) -> Tip blk)
-> AnchoredFragment (HeaderWithTime blk)
-> Their (Tip blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor (HeaderWithTime blk) -> Tip blk
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip (Anchor (HeaderWithTime blk) -> Tip blk)
-> (AnchoredFragment (HeaderWithTime blk)
    -> Anchor (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
-> Tip blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (HeaderWithTime blk)
-> Anchor (HeaderWithTime blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AF.headAnchor

-- | A type-legos auxillary function used in 'readLedgerState'.
castM :: Monad m => m (WithEarlyExit m x) -> WithEarlyExit m x
castM :: forall (m :: * -> *) x.
Monad m =>
m (WithEarlyExit m x) -> WithEarlyExit m x
castM = WithEarlyExit m (WithEarlyExit m x) -> WithEarlyExit m x
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (WithEarlyExit m (WithEarlyExit m x) -> WithEarlyExit m x)
-> (m (WithEarlyExit m x) -> WithEarlyExit m (WithEarlyExit m x))
-> m (WithEarlyExit m x)
-> WithEarlyExit m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (WithEarlyExit m x) -> WithEarlyExit m (WithEarlyExit m x)
forall (m :: * -> *) a. Monad m => m a -> WithEarlyExit m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
EarlyExit.lift

attemptRollback ::
     ( BlockSupportsProtocol blk
     , HasAnnTip blk
     )
  => Point blk
  ->       (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk)
  -> Maybe
       ( AnchoredFragment (HeaderWithTime blk)
       , HeaderStateHistory blk
       , -- The state of the oldest header that was rolled back, if any.
         Maybe (HeaderStateWithTime blk)
       )
attemptRollback :: forall blk.
(BlockSupportsProtocol blk, HasAnnTip blk) =>
Point blk
-> (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk)
-> Maybe
     (AnchoredFragment (HeaderWithTime blk), HeaderStateHistory blk,
      Maybe (HeaderStateWithTime blk))
attemptRollback Point blk
rollBackPoint (AnchoredFragment (HeaderWithTime blk)
frag, HeaderStateHistory blk
state) = do
    frag'                   <- Point (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk)
-> Maybe (AnchoredFragment (HeaderWithTime blk))
forall block.
HasHeader block =>
Point block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
AF.rollback (Point blk -> Point (HeaderWithTime blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
rollBackPoint) AnchoredFragment (HeaderWithTime blk)
frag
    (state', oldestRewound) <- HeaderStateHistory.rewind rollBackPoint state
    return (frag', state', oldestRewound)

{-------------------------------------------------------------------------------
   Looking for newly-recognized trap headers on the existing candidate
-------------------------------------------------------------------------------}

-- | Watch the invalid block checker function for changes (using its
-- fingerprint). Whenever it changes, i.e., a new invalid block is detected,
-- check whether the current candidate fragment contains any header that is
-- invalid, if so, disconnect by throwing an 'InvalidBlock' exception.
--
-- Note that it is possible, yet unlikely, that the candidate fragment
-- contains a header that corresponds to an invalid block, but before we have
-- discovered this (after downloading and validating the block), the upstream
-- node could have rolled back such that its candidate chain no longer
-- contains the invalid block, in which case we do not disconnect from it.
--
-- The cost of this check is \( O(cand * check) \) where /cand/ is the size of
-- the candidate fragment and /check/ is the cost of checking whether a block
-- is invalid (typically \( O(\log(invalid)) \) where /invalid/ is the number
-- of invalid blocks).
invalidBlockRejector ::
  forall m blk.
     ( IOLike m
     , LedgerSupportsProtocol blk
     )
  => Tracer m (TraceChainSyncClientEvent blk)
  -> NodeToNodeVersion
  -> DiffusionPipeliningSupport
  -> STM m (WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk)))
     -- ^ Get the invalid block checker
  -> STM m (AnchoredFragment (HeaderWithTime blk))
     -- ^ Get the candidate
  -> Watcher m
         (WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk)))
         Fingerprint
invalidBlockRejector :: forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
Tracer m (TraceChainSyncClientEvent blk)
-> NodeToNodeVersion
-> DiffusionPipeliningSupport
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
-> STM m (AnchoredFragment (HeaderWithTime blk))
-> Watcher
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
     Fingerprint
invalidBlockRejector Tracer m (TraceChainSyncClientEvent blk)
tracer NodeToNodeVersion
_version DiffusionPipeliningSupport
pipelining STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock STM m (AnchoredFragment (HeaderWithTime blk))
getCandidate =
    Watcher {
        wFingerprint :: WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk))
-> Fingerprint
wFingerprint = WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk))
-> Fingerprint
forall a. WithFingerprint a -> Fingerprint
getFingerprint
      , wInitial :: Maybe Fingerprint
wInitial     = Maybe Fingerprint
forall a. Maybe a
Nothing
      , wNotify :: WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk))
-> m ()
wNotify      = (HeaderHash blk -> Maybe (ExtValidationError blk)) -> m ()
checkInvalid ((HeaderHash blk -> Maybe (ExtValidationError blk)) -> m ())
-> (WithFingerprint
      (HeaderHash blk -> Maybe (ExtValidationError blk))
    -> HeaderHash blk -> Maybe (ExtValidationError blk))
-> WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk))
-> HeaderHash blk -> Maybe (ExtValidationError blk)
forall a. WithFingerprint a -> a
forgetFingerprint
      , wReader :: STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
wReader      = STM
  m
  (WithFingerprint
     (HeaderHash blk -> Maybe (ExtValidationError blk)))
getIsInvalidBlock
      }
  where
    checkInvalid :: (HeaderHash blk -> Maybe (ExtValidationError blk)) -> m ()
    checkInvalid :: (HeaderHash blk -> Maybe (ExtValidationError blk)) -> m ()
checkInvalid HeaderHash blk -> Maybe (ExtValidationError blk)
isInvalidBlock = do
        theirFrag <- STM m (AnchoredFragment (HeaderWithTime blk))
-> m (AnchoredFragment (HeaderWithTime blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (AnchoredFragment (HeaderWithTime blk))
getCandidate
        -- The invalid block is likely to be a more recent block, so check from
        -- newest to oldest.
        --
        -- As of block diffusion pipelining, their tip header might be
        -- tentative. Since they do not yet have a way to explicitly say
        -- whether it is tentative, we assume it is and therefore skip their
        -- tip here. TODO once it's explicit, only skip it if it's annotated as
        -- tentative
        mapM_ (uncurry disconnect)
          $ firstJust
                (\HeaderWithTime blk
hdrWithTime ->
                   let hdr :: Header blk
hdr = HeaderWithTime blk -> Header blk
forall blk. HeaderWithTime blk -> Header blk
hwtHeader HeaderWithTime blk
hdrWithTime in
                     (Header blk
hdr,) (ExtValidationError blk -> (Header blk, ExtValidationError blk))
-> Maybe (ExtValidationError blk)
-> Maybe (Header blk, ExtValidationError blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderHash blk -> Maybe (ExtValidationError blk)
isInvalidBlock (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr)
                )
          $ (   case pipelining of
                    DiffusionPipeliningSupport
DiffusionPipeliningOff -> [HeaderWithTime blk] -> [HeaderWithTime blk]
forall a. a -> a
id
                    DiffusionPipeliningSupport
DiffusionPipeliningOn  ->
                      -- As mentioned in the comment above, if the
                      -- header is tentative we skip the fragment tip,
                      -- dropping the first element.
                      Int -> [HeaderWithTime blk] -> [HeaderWithTime blk]
forall a. Int -> [a] -> [a]
drop Int
1
            )
          $ AF.toNewestFirst theirFrag

    disconnect :: Header blk -> ExtValidationError blk -> m ()
    disconnect :: Header blk -> ExtValidationError blk -> m ()
disconnect Header blk
invalidHeader ExtValidationError blk
reason = do
        let ex :: ChainSyncClientException
ex =
                Point blk
-> HeaderHash blk
-> ExtValidationError blk
-> ChainSyncClientException
forall blk.
LedgerSupportsProtocol blk =>
Point blk
-> HeaderHash blk
-> ExtValidationError blk
-> ChainSyncClientException
InvalidBlock
                  (Header blk -> Point blk
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint Header blk
invalidHeader)
                  (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
invalidHeader)
                  ExtValidationError blk
reason
        Tracer m (TraceChainSyncClientEvent blk)
-> TraceChainSyncClientEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncClientEvent blk)
tracer (TraceChainSyncClientEvent blk -> m ())
-> TraceChainSyncClientEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ ChainSyncClientException -> TraceChainSyncClientEvent blk
forall blk.
ChainSyncClientException -> TraceChainSyncClientEvent blk
TraceException ChainSyncClientException
ex
        ChainSyncClientException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ChainSyncClientException
ex

{-------------------------------------------------------------------------------
  Explicit state
-------------------------------------------------------------------------------}

-- | Make the state maintained by the chain sync client explicit
--
-- The chain sync client contains of a bunch of functions that basically look
-- like "do some network stuff, compute some stuff, and then continue with
-- such-and-such a new state". We want to make sure to keep that state in NF
-- at all times, but since we don't use a TVar to store it, we cannot reuse
-- the existing infrastructure for checking TVars for NF. Instead, we make
-- the state explicit in the types and do the check in 'continueWithState'.
newtype Stateful m blk s st = Stateful (s -> m (Consensus st blk m))

continueWithState ::
     NoThunks s
  => s
  -> Stateful m blk s st
  -> m (Consensus st blk m)
continueWithState :: forall s (m :: * -> *) blk
       (st :: * -> * -> * -> (* -> *) -> * -> *).
NoThunks s =>
s -> Stateful m blk s st -> m (Consensus st blk m)
continueWithState !s
s (Stateful s -> m (Consensus st blk m)
f) =
    Maybe String -> m (Consensus st blk m) -> m (Consensus st blk m)
forall a. HasCallStack => Maybe String -> a -> a
checkInvariant (ThunkInfo -> String
forall a. Show a => a -> String
show (ThunkInfo -> String) -> Maybe ThunkInfo -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Maybe ThunkInfo
forall a. NoThunks a => a -> Maybe ThunkInfo
unsafeNoThunks s
s) (m (Consensus st blk m) -> m (Consensus st blk m))
-> m (Consensus st blk m) -> m (Consensus st blk m)
forall a b. (a -> b) -> a -> b
$ s -> m (Consensus st blk m)
f s
s

{-------------------------------------------------------------------------------
  Return value
-------------------------------------------------------------------------------}

-- | The Chain sync client only _gracefully_ terminates when the upstream
-- node's chain is not interesting (e.g., forked off too far in the past). By
-- gracefully terminating, the network layer can keep the other mini-protocols
-- connect to the same upstream node running.
--
-- For example, a relay node will often receive connections from nodes syncing
-- from scratch or an old chain. Since these nodes have a chain that is shorter
-- than the relay node's chain, it's useless for the relay node to run the
-- client-side of the chain sync protocol. However, the other direction of the
-- protocol, and, e.g., the transaction submission protocol, should keep
-- running.
data ChainSyncClientResult =
    forall blk. BlockSupportsProtocol blk =>
    ForkTooDeep
        (Point blk)  -- ^ Intersection
        (Our   (Tip blk))
        (Their (Tip blk))
    -- ^ The server we're connecting to forked more than @k@ blocks ago.
  |
    forall blk. BlockSupportsProtocol blk =>
    NoMoreIntersection
        (Our   (Tip blk))
        (Their (Tip blk))
    -- ^ Our chain changed such that it no longer intersects with the
    -- candidate's fragment, and asking for a new intersection did not yield
    -- one.
  |
    forall blk. BlockSupportsProtocol blk =>
    RolledBackPastIntersection
        (Point blk)  -- ^ Point asked to roll back to
        (Our   (Tip blk))
        (Their (Tip blk))
    -- ^ We were asked to roll back past the anchor point of the candidate's
    -- fragment. This means the candidate chain no longer forks off within @k@,
    -- making it impossible to switch to.
  |
    AskedToTerminate
    -- ^ We were asked to terminate via the 'ControlMessageSTM'

deriving instance Show ChainSyncClientResult

instance Eq ChainSyncClientResult where
    == :: ChainSyncClientResult -> ChainSyncClientResult -> Bool
(==)
        (ForkTooDeep (Point blk
a  :: Point blk)  Our (Tip blk)
b  Their (Tip blk)
c )
        (ForkTooDeep (Point blk
a' :: Point blk') Our (Tip blk)
b' Their (Tip blk)
c')
      | Just blk :~: blk
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @blk @blk'
      = (Point blk
a, Our (Tip blk)
b, Their (Tip blk)
c) (Point blk, Our (Tip blk), Their (Tip blk))
-> (Point blk, Our (Tip blk), Their (Tip blk)) -> Bool
forall a. Eq a => a -> a -> Bool
== (Point blk
Point blk
a', Our (Tip blk)
Our (Tip blk)
b', Their (Tip blk)
Their (Tip blk)
c')

    (==)
        (NoMoreIntersection (Our (Tip blk)
a  :: Our (Tip blk )) Their (Tip blk)
b )
        (NoMoreIntersection (Our (Tip blk)
a' :: Our (Tip blk')) Their (Tip blk)
b')
      | Just blk :~: blk
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @blk @blk'
      = (Our (Tip blk)
a, Their (Tip blk)
b) (Our (Tip blk), Their (Tip blk))
-> (Our (Tip blk), Their (Tip blk)) -> Bool
forall a. Eq a => a -> a -> Bool
== (Our (Tip blk)
Our (Tip blk)
a', Their (Tip blk)
Their (Tip blk)
b')

    (==)
        (RolledBackPastIntersection (Point blk
a  :: Point blk ) Our (Tip blk)
b  Their (Tip blk)
c )
        (RolledBackPastIntersection (Point blk
a' :: Point blk') Our (Tip blk)
b' Their (Tip blk)
c')
      | Just blk :~: blk
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @blk @blk'
      = (Point blk
a, Our (Tip blk)
b, Their (Tip blk)
c) (Point blk, Our (Tip blk), Their (Tip blk))
-> (Point blk, Our (Tip blk), Their (Tip blk)) -> Bool
forall a. Eq a => a -> a -> Bool
== (Point blk
Point blk
a', Our (Tip blk)
Our (Tip blk)
b', Their (Tip blk)
Their (Tip blk)
c')

    ChainSyncClientResult
AskedToTerminate == ChainSyncClientResult
AskedToTerminate = Bool
True

    ForkTooDeep{}                == ChainSyncClientResult
_ = Bool
False
    NoMoreIntersection{}         == ChainSyncClientResult
_ = Bool
False
    RolledBackPastIntersection{} == ChainSyncClientResult
_ = Bool
False
    ChainSyncClientResult
AskedToTerminate             == ChainSyncClientResult
_ = Bool
False

{-------------------------------------------------------------------------------
  Exception
-------------------------------------------------------------------------------}

-- | When the upstream node violates the protocol or exhibits malicious
-- behaviour, e.g., serving an invalid header or a header corresponding to a
-- known invalid block, we throw an exception to disconnect. This will bring
-- down all miniprotocols in both directions with that node.
data ChainSyncClientException =
    forall blk. (BlockSupportsProtocol blk, ValidateEnvelope blk) =>
    HeaderError
        (Point blk)  -- ^ Invalid header
        (HeaderError blk)
        (Our   (Tip blk))
        (Their (Tip blk))
    -- ^ Header validation threw an error.
  |
    forall blk. BlockSupportsProtocol blk =>
    InvalidIntersection
        (Point blk)  -- ^ Intersection
        (Our   (Tip blk))
        (Their (Tip blk))
    -- ^ We send the upstream node a bunch of points from a chain fragment and
    -- the upstream node responded with an intersection point that is not on
    -- our chain fragment, and thus not among the points we sent.
    --
    -- We store the intersection point the upstream node sent us.
  |
    forall blk. LedgerSupportsProtocol blk =>
    InvalidBlock
        (Point blk)
        -- ^ Block that triggered the validity check.
        (HeaderHash blk)
        -- ^ Invalid block. If pipelining was negotiated, this can be
        -- different from the previous argument.
        (ExtValidationError blk)
    -- ^ The upstream node's chain contained a block that we know is invalid.
  |
    forall blk. BlockSupportsProtocol blk =>
    CandidateTooSparse
        (Point blk) -- ^ Intersection
        (Our   (Tip blk))
        (Their (Tip blk))
    -- ^ The upstream node's chain was so sparse that it was worse than our
    -- selection despite being blocked on the forecast horizon.
  |
    InFutureHeaderExceedsClockSkew !InFutureCheck.HeaderArrivalException
    -- ^ A header arrived from the far future.
  |
    HistoricityError !HistoricityException
  |
    EmptyBucket
    -- ^ The peer lost its race against the bucket.
  |
    InvalidJumpResponse
    -- ^ When the peer responded incorrectly to a jump request.
  | DensityTooLow
    -- ^ The peer has been deemed unworthy by the GDD

deriving instance Show ChainSyncClientException

instance Eq ChainSyncClientException where
    == :: ChainSyncClientException -> ChainSyncClientException -> Bool
(==)
        (HeaderError (Point blk
a  :: Point blk ) HeaderError blk
b  Our (Tip blk)
c  Their (Tip blk)
d )
        (HeaderError (Point blk
a' :: Point blk') HeaderError blk
b' Our (Tip blk)
c' Their (Tip blk)
d')
      | Just blk :~: blk
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @blk @blk'
      = (Point blk
a, HeaderError blk
b, Our (Tip blk)
c, Their (Tip blk)
d) (Point blk, HeaderError blk, Our (Tip blk), Their (Tip blk))
-> (Point blk, HeaderError blk, Our (Tip blk), Their (Tip blk))
-> Bool
forall a. Eq a => a -> a -> Bool
== (Point blk
Point blk
a', HeaderError blk
HeaderError blk
b', Our (Tip blk)
Our (Tip blk)
c', Their (Tip blk)
Their (Tip blk)
d')

    (==)
        (InvalidIntersection (Point blk
a  :: Point blk ) Our (Tip blk)
b  Their (Tip blk)
c )
        (InvalidIntersection (Point blk
a' :: Point blk') Our (Tip blk)
b' Their (Tip blk)
c')
      | Just blk :~: blk
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @blk @blk'
      = (Point blk
a, Our (Tip blk)
b, Their (Tip blk)
c) (Point blk, Our (Tip blk), Their (Tip blk))
-> (Point blk, Our (Tip blk), Their (Tip blk)) -> Bool
forall a. Eq a => a -> a -> Bool
== (Point blk
Point blk
a', Our (Tip blk)
Our (Tip blk)
b', Their (Tip blk)
Their (Tip blk)
c')

    (==)
        (InvalidBlock (Point blk
a  :: Point blk)  HeaderHash blk
b  ExtValidationError blk
c )
        (InvalidBlock (Point blk
a' :: Point blk') HeaderHash blk
b' ExtValidationError blk
c')
      | Just blk :~: blk
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @blk @blk'
      = (Point blk
a, HeaderHash blk
b, ExtValidationError blk
c) (Point blk, HeaderHash blk, ExtValidationError blk)
-> (Point blk, HeaderHash blk, ExtValidationError blk) -> Bool
forall a. Eq a => a -> a -> Bool
== (Point blk
Point blk
a', HeaderHash blk
HeaderHash blk
b', ExtValidationError blk
ExtValidationError blk
c')

    (==)
        (CandidateTooSparse (Point blk
a  :: Point blk ) Our (Tip blk)
b  Their (Tip blk)
c )
        (CandidateTooSparse (Point blk
a' :: Point blk') Our (Tip blk)
b' Their (Tip blk)
c')
      | Just blk :~: blk
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @blk @blk'
      = (Point blk
a, Our (Tip blk)
b, Their (Tip blk)
c) (Point blk, Our (Tip blk), Their (Tip blk))
-> (Point blk, Our (Tip blk), Their (Tip blk)) -> Bool
forall a. Eq a => a -> a -> Bool
== (Point blk
Point blk
a', Our (Tip blk)
Our (Tip blk)
b', Their (Tip blk)
Their (Tip blk)
c')

    (==)
        (InFutureHeaderExceedsClockSkew HeaderArrivalException
a )
        (InFutureHeaderExceedsClockSkew HeaderArrivalException
a')
      = HeaderArrivalException
a HeaderArrivalException -> HeaderArrivalException -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderArrivalException
a'

    (==)
        (HistoricityError HistoricityException
a )
        (HistoricityError HistoricityException
a')
      = HistoricityException
a HistoricityException -> HistoricityException -> Bool
forall a. Eq a => a -> a -> Bool
== HistoricityException
a'

    (==)
        ChainSyncClientException
EmptyBucket ChainSyncClientException
EmptyBucket
      = Bool
True
    (==)
        ChainSyncClientException
InvalidJumpResponse ChainSyncClientException
InvalidJumpResponse
      = Bool
True
    (==)
        ChainSyncClientException
DensityTooLow ChainSyncClientException
DensityTooLow
      = Bool
True

    HeaderError{}                    == ChainSyncClientException
_ = Bool
False
    InvalidIntersection{}            == ChainSyncClientException
_ = Bool
False
    InvalidBlock{}                   == ChainSyncClientException
_ = Bool
False
    CandidateTooSparse{}             == ChainSyncClientException
_ = Bool
False
    InFutureHeaderExceedsClockSkew{} == ChainSyncClientException
_ = Bool
False
    HistoricityError{}               == ChainSyncClientException
_ = Bool
False
    ChainSyncClientException
EmptyBucket                      == ChainSyncClientException
_ = Bool
False
    ChainSyncClientException
InvalidJumpResponse              == ChainSyncClientException
_ = Bool
False
    ChainSyncClientException
DensityTooLow                    == ChainSyncClientException
_ = Bool
False

instance Exception ChainSyncClientException

{-------------------------------------------------------------------------------
  Trace events
-------------------------------------------------------------------------------}

-- | Events traced by the Chain Sync Client.
data TraceChainSyncClientEvent blk =
    TraceDownloadedHeader (Header blk)
    -- ^ While following a candidate chain, we rolled forward by downloading a
    -- header.
  |
    TraceRolledBack (Point blk)
    -- ^ While following a candidate chain, we rolled back to the given point.
  |
    TraceFoundIntersection (Point blk) (Our (Tip blk)) (Their (Tip blk))
    -- ^ We found an intersection between our chain fragment and the
    -- candidate's chain.
  |
    TraceException ChainSyncClientException
    -- ^ An exception was thrown by the Chain Sync Client.
  |
    TraceTermination ChainSyncClientResult
    -- ^ The client has terminated.
  |
    TraceValidatedHeader (Header blk)
    -- ^ We have validated the given header.
  |
    TraceWaitingBeyondForecastHorizon SlotNo
    -- ^ The 'SlotNo' is beyond the forecast horizon, the ChainSync client
    -- cannot yet validate a header in this slot and therefore is waiting.
  |
    TraceAccessingForecastHorizon SlotNo
    -- ^ The 'SlotNo', which was previously beyond the forecast horizon, has now
    -- entered it, and we can resume processing.
  |
    TraceGaveLoPToken Bool (Header blk) BlockNo
    -- ^ Whether we added a token to the LoP bucket of the peer. Also carries
    -- the considered header and the best block number known prior to this
    -- header.
  |
    TraceOfferJump (Point blk)
    -- ^ ChainSync Jumping offering a point to jump to.
  |
    TraceJumpResult (Jumping.JumpResult blk)
    -- ^ ChainSync Jumping -- reply.
  |
    TraceJumpingWaitingForNextInstruction
    -- ^ ChainSync Jumping -- the ChainSync client is requesting the next
    -- instruction.
  |
    TraceJumpingInstructionIs (Jumping.Instruction blk)
    -- ^ ChainSync Jumping -- the ChainSync client got its next instruction.
  |
    forall n. TraceDrainingThePipe (Nat n)

deriving instance
  ( BlockSupportsProtocol blk
  , Show (Header blk)
  )
  => Show (TraceChainSyncClientEvent blk)