{-# 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
  { ChainSyncLoPBucketEnabledConfig -> Integer
csbcCapacity :: Integer
  -- ^ The capacity of the bucket (think number of tokens).
  , ChainSyncLoPBucketEnabledConfig -> Rational
csbcRate :: Rational
  -- ^ The rate of the bucket (think tokens per second).
  }
  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
  { CSJEnabledConfig -> SlotNo
csjcJumpSize :: SlotNo
  -- ^ 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).
  }
  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
  { forall (m :: * -> *). Idling m -> m ()
idlingStart :: !(m ())
  -- ^ Mark the peer as being idle.
  , forall (m :: * -> *). Idling m -> m ()
idlingStop :: !(m ())
  -- ^ Mark the peer as not being idle.
  }
  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
  { forall (m :: * -> *). LoPBucket m -> m ()
lbPause :: !(m ())
  -- ^ Pause the bucket, because the peer is alert and we're waiting for some
  -- condition.
  , forall (m :: * -> *). LoPBucket m -> m ()
lbResume :: !(m ())
  -- ^ Resume the bucket after pausing it.
  , forall (m :: * -> *). LoPBucket m -> m ()
lbGrantToken :: !(m ())
  -- ^ Notify the bucket that the peer has sent an interesting header.
  }
  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
  { forall (m :: * -> *) blk.
ChainSyncStateView m blk
-> AnchoredFragment (HeaderWithTime blk) -> STM m ()
csvSetCandidate :: !(AnchoredFragment (HeaderWithTime blk) -> STM m ())
  -- ^ The current candidate fragment
  , forall (m :: * -> *) blk.
ChainSyncStateView m blk -> WithOrigin SlotNo -> STM m ()
csvSetLatestSlot :: !(WithOrigin SlotNo -> STM m ())
  -- ^ Update the slot of the latest received header
  , forall (m :: * -> *) blk. ChainSyncStateView m blk -> Idling m
csvIdling :: !(Idling m)
  -- ^ (Un)mark the peer as idling.
  , forall (m :: * -> *) blk. ChainSyncStateView m blk -> LoPBucket m
csvLoPBucket :: !(LoPBucket m)
  -- ^ Control the 'LeakyBucket' for the LoP.
  , forall (m :: * -> *) blk. ChainSyncStateView m blk -> Jumping m blk
csvJumping :: !(Jumping.Jumping m blk)
  -- ^ Jumping-related API.
  }
  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 ->
  -- | The kill handle and states for each peer, we need the whole map because we
  -- (de)register nodes (@peer@).
  ChainSyncClientHandleCollection peer m blk ->
  -- | A function giving the current GSM state; only used at startup.
  STM m GsmState ->
  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
            gsmState <- STM m GsmState
getGsmState
            updateLopBucketConfig lopBucket gsmState 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
        gsmState <- STM m GsmState
getGsmState
        updateLopBucketConfig lopBucket gsmState time
        cschJumpInfo <- newTVar Nothing
        context <- Jumping.makeContext varHandles jumpSize tracerCsj
        Jumping.registerClient gsmState 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
            , -- See Note [Updating the CSJ State when the GSM State Changes]
              -- in the Haddocks of 'Jumping.registerClient'.
              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 ->
  -- | Peer's best block; needed to build an 'UnknownIntersectionState'.
  BlockNo ->
  -- | Exception to throw when no intersection is found.
  (Our (Tip blk) -> Their (Tip blk) -> ChainSyncClientResult) ->
  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
 where
  -- 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.

  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
     in -- TODO cache this in the KnownIntersectionState? Or even in the
        -- LedgerDB?

        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 ->
  -- | onset of the header's slot
  RelativeTime ->
  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
  = -- | 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.)
    NoLongerIntersects
  | 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 ->
  -- | Get the invalid block checker
  STM m (WithFingerprint (HeaderHash blk -> Maybe (ExtValidationError blk))) ->
  -- | Get the candidate
  STM m (AnchoredFragment (HeaderWithTime blk)) ->
  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
      -- | Intersection
      (Point blk)
      (Our (Tip blk))
      -- | The server we're connecting to forked more than @k@ blocks ago.
      (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 =>
    NoMoreIntersection
      (Our (Tip blk))
      (Their (Tip blk))
  | forall blk.
    BlockSupportsProtocol blk =>
    RolledBackPastIntersection
      -- | Point asked to roll back to
      (Point blk)
      (Our (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.
      (Their (Tip blk))
  | -- | We were asked to terminate via the 'ControlMessageSTM'
    AskedToTerminate

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
      -- | Invalid header
      (Point blk)
      (HeaderError blk)
      (Our (Tip blk))
      -- | Header validation threw an error.
      (Their (Tip blk))
  | forall blk.
    BlockSupportsProtocol blk =>
    InvalidIntersection
      -- | Intersection
      (Point blk)
      (Our (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.
      (Their (Tip blk))
  | forall blk.
    LedgerSupportsProtocol blk =>
    InvalidBlock
      -- | Block that triggered the validity check.
      (Point blk)
      -- | Invalid block. If pipelining was negotiated, this can be
      -- different from the previous argument.
      (HeaderHash blk)
      -- | The upstream node's chain contained a block that we know is invalid.
      (ExtValidationError blk)
  | forall blk.
    BlockSupportsProtocol blk =>
    CandidateTooSparse
      -- | Intersection
      (Point blk)
      (Our (Tip blk))
      -- | The upstream node's chain was so sparse that it was worse than our
      -- selection despite being blocked on the forecast horizon.
      (Their (Tip blk))
  | -- | A header arrived from the far future.
    InFutureHeaderExceedsClockSkew !InFutureCheck.HeaderArrivalException
  | HistoricityError !HistoricityException
  | -- | The peer lost its race against the bucket.
    EmptyBucket
  | -- | When the peer responded incorrectly to a jump request.
    InvalidJumpResponse
  | -- | The peer has been deemed unworthy by the GDD
    DensityTooLow

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

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