{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Initialization of the 'BlockFetchConsensusInterface'
module Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface (
    ChainDbView (..)
  , defaultChainDbView
  , mkBlockFetchConsensusInterface
  , readFetchModeDefault
  ) where

import           Cardano.Network.ConsensusMode (ConsensusMode)
import           Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers,
                     requiresBootstrapPeers)
import           Cardano.Network.Types (LedgerStateJudgement)
import           Control.Monad
import           Control.Tracer (Tracer)
import           Data.Map.Strict (Map)
import           Data.Time.Clock (UTCTime)
import           GHC.Stack (HasCallStack)
import           Ouroboros.Consensus.Block hiding (blockMatchesHeader)
import qualified Ouroboros.Consensus.Block as Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config
import qualified Ouroboros.Consensus.Config.SupportsNode as SupportsNode
import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
import           Ouroboros.Consensus.Ledger.SupportsProtocol
                     (LedgerSupportsProtocol)
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as CSJumping
import           Ouroboros.Consensus.Storage.ChainDB.API (AddBlockPromise,
                     ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import           Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment
                     (InvalidBlockPunishment)
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment
import           Ouroboros.Consensus.Util.AnchoredFragment
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (MaxSlotNo)
import           Ouroboros.Network.BlockFetch.ConsensusInterface
                     (BlockFetchConsensusInterface (..), ChainSelStarvation,
                     FetchMode (..), FromConsensus (..), PraosFetchMode (..),
                     mkReadFetchMode)
import           Ouroboros.Network.SizeInBytes

-- | 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 (AnchoredFragment (HeaderWithTime blk))
getCurrentChainWithTime   :: STM m (AnchoredFragment (HeaderWithTime blk))
   , forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (Point blk -> Bool)
getIsFetched              :: STM m (Point blk -> Bool)
   , forall (m :: * -> *) blk. ChainDbView m blk -> STM m MaxSlotNo
getMaxSlotNo              :: STM m MaxSlotNo
   , forall (m :: * -> *) blk.
ChainDbView m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
addBlockAsync             :: InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
   , forall (m :: * -> *) blk.
ChainDbView m blk -> STM m ChainSelStarvation
getChainSelStarvation     :: STM m ChainSelStarvation
   }

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
  , getCurrentChainWithTime :: STM m (AnchoredFragment (HeaderWithTime blk))
getCurrentChainWithTime   = ChainDB m blk -> STM m (AnchoredFragment (HeaderWithTime blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (HeaderWithTime blk))
ChainDB.getCurrentChainWithTime ChainDB m blk
chainDB
  , getIsFetched :: STM m (Point blk -> Bool)
getIsFetched              = ChainDB m blk -> STM m (Point blk -> Bool)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (Point blk -> Bool)
ChainDB.getIsFetched ChainDB m blk
chainDB
  , getMaxSlotNo :: STM m MaxSlotNo
getMaxSlotNo              = ChainDB m blk -> STM m MaxSlotNo
forall (m :: * -> *) blk. ChainDB m blk -> STM m MaxSlotNo
ChainDB.getMaxSlotNo ChainDB m blk
chainDB
  , addBlockAsync :: InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
addBlockAsync             = ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
forall (m :: * -> *) blk.
ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
ChainDB.addBlockAsync ChainDB m blk
chainDB
  , getChainSelStarvation :: STM m ChainSelStarvation
getChainSelStarvation     = ChainDB m blk -> STM m ChainSelStarvation
forall (m :: * -> *) blk. ChainDB m blk -> STM m ChainSelStarvation
ChainDB.getChainSelStarvation ChainDB m blk
chainDB
  }

readFetchModeDefault ::
     (MonadSTM m, HasHeader blk)
  => ConsensusMode
  -> BlockchainTime m
  -> STM m (AnchoredFragment blk)
  -> STM m UseBootstrapPeers
  -> STM m LedgerStateJudgement
  -> STM m FetchMode
readFetchModeDefault :: forall (m :: * -> *) blk.
(MonadSTM m, HasHeader blk) =>
ConsensusMode
-> BlockchainTime m
-> STM m (AnchoredFragment blk)
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m FetchMode
readFetchModeDefault ConsensusMode
consensusMode BlockchainTime m
btime STM m (AnchoredFragment blk)
getCurrentChain
                     STM m UseBootstrapPeers
getUseBootstrapPeers STM m LedgerStateJudgement
getLedgerStateJudgement =
    ConsensusMode
-> STM m LedgerStateJudgement
-> STM m PraosFetchMode
-> STM m FetchMode
forall (m :: * -> *).
Functor m =>
ConsensusMode
-> m LedgerStateJudgement -> m PraosFetchMode -> m FetchMode
mkReadFetchMode ConsensusMode
consensusMode STM m LedgerStateJudgement
getLedgerStateJudgement STM m PraosFetchMode
praosFetchMode
  where
    praosFetchMode :: STM m PraosFetchMode
praosFetchMode = do
      mCurSlot <- BlockchainTime m -> STM m CurrentSlot
forall (m :: * -> *). BlockchainTime m -> STM m CurrentSlot
getCurrentSlot BlockchainTime m
btime
      usingBootstrapPeers <- requiresBootstrapPeers <$> getUseBootstrapPeers
                                                    <*> getLedgerStateJudgement

      -- This logic means that when the node is using bootstrap peers and is in
      -- TooOld state it will always return BulkSync. Otherwise if the node
      -- isn't using bootstrap peers (i.e. has them disabled it will use the old
      -- logic of returning BulkSync if behind 1000 slots
      case (usingBootstrapPeers, mCurSlot) of
        (Bool
True, CurrentSlot
_)                    -> PraosFetchMode -> STM m PraosFetchMode
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return PraosFetchMode
FetchModeBulkSync
        (Bool
False, CurrentSlot
CurrentSlotUnknown)  -> PraosFetchMode -> STM m PraosFetchMode
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return PraosFetchMode
FetchModeBulkSync
        (Bool
False, CurrentSlot SlotNo
curSlot) -> do
          curChainSlot <- AnchoredFragment blk -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot (AnchoredFragment blk -> WithOrigin SlotNo)
-> STM m (AnchoredFragment blk) -> STM m (WithOrigin SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (AnchoredFragment blk)
getCurrentChain
          let slotsBehind = case WithOrigin SlotNo
curChainSlot of
                -- There's nothing in the chain. If the current slot is 0, then
                -- we're 1 slot behind.
                WithOrigin SlotNo
Origin         -> SlotNo -> Word64
unSlotNo SlotNo
curSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
                NotOrigin SlotNo
slot -> SlotNo -> Word64
unSlotNo SlotNo
curSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- SlotNo -> Word64
unSlotNo SlotNo
slot
              maxSlotsBehind = Word64
1000
          return $ if slotsBehind < maxSlotsBehind
            -- When the current chain is near to "now", use deadline mode,
            -- when it is far away, use bulk sync mode.
            then FetchModeDeadline
            else FetchModeBulkSync

mkBlockFetchConsensusInterface ::
     forall m peer blk.
     ( IOLike m
     , BlockSupportsDiffusionPipelining blk
     , Ord peer
     , LedgerSupportsProtocol blk
     , SupportsNode.ConfigSupportsNode blk
     )
  => Tracer m (CSJumping.TraceEventDbf peer)
  -> BlockConfig blk
  -> ChainDbView m blk
  -> CSClient.ChainSyncClientHandleCollection peer m blk
  -> (Header blk -> SizeInBytes)
  -> STM m FetchMode
     -- ^ See 'readFetchMode'.
  -> DiffusionPipeliningSupport
  -> BlockFetchConsensusInterface peer (HeaderWithTime blk) blk m
mkBlockFetchConsensusInterface :: forall (m :: * -> *) peer blk.
(IOLike m, BlockSupportsDiffusionPipelining blk, Ord peer,
 LedgerSupportsProtocol blk, ConfigSupportsNode blk) =>
Tracer m (TraceEventDbf peer)
-> BlockConfig blk
-> ChainDbView m blk
-> ChainSyncClientHandleCollection peer m blk
-> (Header blk -> SizeInBytes)
-> STM m FetchMode
-> DiffusionPipeliningSupport
-> BlockFetchConsensusInterface peer (HeaderWithTime blk) blk m
mkBlockFetchConsensusInterface
  Tracer m (TraceEventDbf peer)
csjTracer BlockConfig blk
bcfg ChainDbView m blk
chainDB ChainSyncClientHandleCollection peer m blk
csHandlesCol Header blk -> SizeInBytes
blockFetchSize STM m FetchMode
readFetchMode DiffusionPipeliningSupport
pipelining =
    BlockFetchConsensusInterface {blockFetchSize :: HeaderWithTime blk -> SizeInBytes
blockFetchSize = Header blk -> SizeInBytes
blockFetchSize (Header blk -> SizeInBytes)
-> (HeaderWithTime blk -> Header blk)
-> HeaderWithTime blk
-> SizeInBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderWithTime blk -> Header blk
forall blk. HeaderWithTime blk -> Header blk
hwtHeader, STM m (Map peer (AnchoredFragment (HeaderWithTime blk)))
STM m (AnchoredFragment (HeaderWithTime blk))
STM m MaxSlotNo
STM m ChainSelStarvation
STM m FetchMode
STM m (Point blk -> Bool)
STM m (Point blk -> blk -> m ())
peer -> m ()
HasCallStack =>
AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk) -> Bool
HasCallStack =>
AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk) -> Ordering
AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk) -> Bool
AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk) -> Ordering
FromConsensus (HeaderWithTime blk) -> STM m UTCTime
HeaderWithTime blk -> blk -> Bool
readFetchMode :: STM m FetchMode
readFetchMode :: STM m FetchMode
blockMatchesHeader :: HeaderWithTime blk -> blk -> Bool
readCandidateChains :: STM m (Map peer (AnchoredFragment (HeaderWithTime blk)))
readCurrentChain :: STM m (AnchoredFragment (HeaderWithTime blk))
readFetchedBlocks :: STM m (Point blk -> Bool)
mkAddFetchedBlock :: STM m (Point blk -> blk -> m ())
readFetchedMaxSlotNo :: STM m MaxSlotNo
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk) -> Bool
compareCandidateChains :: AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk) -> Ordering
headerForgeUTCTime :: FromConsensus (HeaderWithTime blk) -> STM m UTCTime
readChainSelStarvation :: STM m ChainSelStarvation
demoteChainSyncJumpingDynamo :: peer -> m ()
demoteChainSyncJumpingDynamo :: peer -> m ()
readChainSelStarvation :: STM m ChainSelStarvation
headerForgeUTCTime :: FromConsensus (HeaderWithTime blk) -> STM m UTCTime
blockMatchesHeader :: HeaderWithTime blk -> blk -> Bool
compareCandidateChains :: HasCallStack =>
AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk) -> Ordering
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk) -> Bool
readFetchedMaxSlotNo :: STM m MaxSlotNo
mkAddFetchedBlock :: STM m (Point blk -> blk -> m ())
readFetchedBlocks :: STM m (Point blk -> Bool)
readCurrentChain :: STM m (AnchoredFragment (HeaderWithTime blk))
readCandidateChains :: STM m (Map peer (AnchoredFragment (HeaderWithTime blk)))
..}
  where
    getCandidates :: STM m (Map peer (AnchoredFragment (HeaderWithTime blk)))
    getCandidates :: STM m (Map peer (AnchoredFragment (HeaderWithTime blk)))
getCandidates = STM m (Map peer (ChainSyncClientHandle m blk))
-> (ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk))
-> STM m (Map peer (AnchoredFragment (HeaderWithTime blk)))
forall (m :: * -> *) peer blk a.
IOLike m =>
STM m (Map peer (ChainSyncClientHandle m blk))
-> (ChainSyncState blk -> a) -> STM m (Map peer a)
CSClient.viewChainSyncState (ChainSyncClientHandleCollection peer m blk
-> STM m (Map peer (ChainSyncClientHandle m blk))
forall peer (m :: * -> *) blk.
ChainSyncClientHandleCollection peer m blk
-> STM m (Map peer (ChainSyncClientHandle m blk))
CSClient.cschcMap ChainSyncClientHandleCollection peer m blk
csHandlesCol) ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk)
forall blk.
ChainSyncState blk -> AnchoredFragment (HeaderWithTime blk)
CSClient.csCandidate

    blockMatchesHeader :: HeaderWithTime blk -> blk -> Bool
    blockMatchesHeader :: HeaderWithTime blk -> blk -> Bool
blockMatchesHeader HeaderWithTime blk
hwt blk
b = Header blk -> blk -> Bool
forall blk. GetHeader blk => Header blk -> blk -> Bool
Block.blockMatchesHeader (HeaderWithTime blk -> Header blk
forall blk. HeaderWithTime blk -> Header blk
hwtHeader HeaderWithTime blk
hwt) blk
b

    readCandidateChains :: STM m (Map peer (AnchoredFragment (HeaderWithTime blk)))
    readCandidateChains :: STM m (Map peer (AnchoredFragment (HeaderWithTime blk)))
readCandidateChains = STM m (Map peer (AnchoredFragment (HeaderWithTime blk)))
getCandidates

    readCurrentChain :: STM m (AnchoredFragment (HeaderWithTime blk))
    readCurrentChain :: STM m (AnchoredFragment (HeaderWithTime blk))
readCurrentChain = ChainDbView m blk -> STM m (AnchoredFragment (HeaderWithTime blk))
forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (AnchoredFragment (HeaderWithTime blk))
getCurrentChainWithTime ChainDbView m blk
chainDB

    readFetchedBlocks :: STM m (Point blk -> Bool)
    readFetchedBlocks :: STM m (Point blk -> Bool)
readFetchedBlocks = ChainDbView m blk -> STM m (Point blk -> Bool)
forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (Point blk -> Bool)
getIsFetched ChainDbView m blk
chainDB

    -- See 'mkAddFetchedBlock_'
    mkAddFetchedBlock ::
      STM m (Point blk -> blk -> m ())
    mkAddFetchedBlock :: STM m (Point blk -> blk -> m ())
mkAddFetchedBlock = do
      pipeliningPunishment <- STM
  m
  (BlockConfig blk
   -> Header blk
   -> InvalidBlockPunishment m
   -> InvalidBlockPunishment m)
forall (m :: * -> *) blk.
(IOLike m, BlockSupportsDiffusionPipelining blk) =>
STM
  m
  (BlockConfig blk
   -> Header blk
   -> InvalidBlockPunishment m
   -> InvalidBlockPunishment m)
InvalidBlockPunishment.mkForDiffusionPipelining
      pure $ mkAddFetchedBlock_ pipeliningPunishment pipelining

    -- Hand over the block to the ChainDB, but don't wait until it has been
    -- written to disk or processed.
    mkAddFetchedBlock_ ::
         (   BlockConfig blk
          -> Header blk
          -> InvalidBlockPunishment m
          -> InvalidBlockPunishment m
         )
      -> DiffusionPipeliningSupport
      -> Point blk
      -> blk
      -> m ()
    mkAddFetchedBlock_ :: (BlockConfig blk
 -> Header blk
 -> InvalidBlockPunishment m
 -> InvalidBlockPunishment m)
-> DiffusionPipeliningSupport -> Point blk -> blk -> m ()
mkAddFetchedBlock_ BlockConfig blk
-> Header blk
-> InvalidBlockPunishment m
-> InvalidBlockPunishment m
pipeliningPunishment DiffusionPipeliningSupport
enabledPipelining Point blk
_pt blk
blk = m (AddBlockPromise m blk) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (AddBlockPromise m blk) -> m ())
-> m (AddBlockPromise m blk) -> m ()
forall a b. (a -> b) -> a -> b
$ do
       disconnect <- m (InvalidBlockPunishment m)
forall (m :: * -> *). IOLike m => m (InvalidBlockPunishment m)
InvalidBlockPunishment.mkPunishThisThread
       -- A BlockFetch peer can either send an entire range or none of the
       -- range; anything else will incur a disconnect. And in 'FetchDeadline'
       -- mode, which is the relevant case for this kind of DoS attack (because
       -- in bulk sync, our honest peers will be streaming a very dense chain
       -- very quickly, meaning the adversary only has very small windows during
       -- which we're interested in its chains), the node only requests whole
       -- suffixes from peers: the BlockFetch decision logic does not avoid
       -- requesting a block that is already in-flight from other peers. Thus
       -- the adversary cannot send us blocks out-of-order (during
       -- 'FetchDeadline'), even if they control more than one of our peers.
       --
       -- Therefore, the following punishment logic only needs to cover the
       -- "whole chain received in-order from a single-peer" case. Which it
       -- currently does.
       --
       -- TODO maintain the context of which ChainSync candidate incurring this
       -- fetch request, and disconnect immediately if the invalid block is not
       -- the tip of that candidate. As-is, in 'FetchDeadline' they must also
       -- send the next block, but they might be able to wait long enough that
       -- it is not desirable when it arrives, and therefore not be disconnected
       -- from. So their choices are: cause a disconnect or else do nothing for
       -- long enough. Both are fine by us, from a DoS mitigation perspective.
       let punishment = (Invalidity -> InvalidBlockPunishment m)
-> InvalidBlockPunishment m
forall (m :: * -> *).
(Invalidity -> InvalidBlockPunishment m)
-> InvalidBlockPunishment m
InvalidBlockPunishment.branch ((Invalidity -> InvalidBlockPunishment m)
 -> InvalidBlockPunishment m)
-> (Invalidity -> InvalidBlockPunishment m)
-> InvalidBlockPunishment m
forall a b. (a -> b) -> a -> b
$ \case
             -- invalid parents always cause a disconnect
             Invalidity
InvalidBlockPunishment.BlockPrefix -> InvalidBlockPunishment m
disconnect
             -- when pipelining, we forgive an invalid block itself if it's
             -- better than the previous invalid block this peer delivered
             Invalidity
InvalidBlockPunishment.BlockItself -> case DiffusionPipeliningSupport
enabledPipelining of
               DiffusionPipeliningSupport
DiffusionPipeliningOff -> InvalidBlockPunishment m
disconnect
               DiffusionPipeliningSupport
DiffusionPipeliningOn  ->
                 BlockConfig blk
-> Header blk
-> InvalidBlockPunishment m
-> InvalidBlockPunishment m
pipeliningPunishment BlockConfig blk
bcfg (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk) InvalidBlockPunishment m
disconnect
       addBlockAsync
         chainDB
         punishment
         blk

    readFetchedMaxSlotNo :: STM m MaxSlotNo
    readFetchedMaxSlotNo :: STM m MaxSlotNo
readFetchedMaxSlotNo = ChainDbView m blk -> STM m MaxSlotNo
forall (m :: * -> *) blk. ChainDbView m blk -> STM m MaxSlotNo
getMaxSlotNo ChainDbView m blk
chainDB

    -- Note that @ours@ comes from the ChainDB and @cand@ from the ChainSync
    -- client.
    --
    -- Fragments are proxies for their corresponding chains; it is possible, in
    -- principle, that an empty fragment corresponds to the chain we want to
    -- adopt, and should therefore be preferred over other fragments (whose
    -- blocks we therefore do not want to download). The precondition to
    -- 'preferAnchoredCandidates' is designed precisely to rule out this
    -- possibility (for details, see the Consensus Report), but unfortunately we
    -- cannot always satisfy this precondition: although the chain sync client
    -- preserves an invariant that relates our current chain to the candidate
    -- fragment, by the time the block fetch download logic considers the
    -- fragment, our current chain might have changed.
    plausibleCandidateChain :: HasCallStack
                            => AnchoredFragment (HeaderWithTime blk)
                            -> AnchoredFragment (HeaderWithTime blk)
                            -> Bool
    plausibleCandidateChain :: HasCallStack =>
AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk) -> Bool
plausibleCandidateChain AnchoredFragment (HeaderWithTime blk)
ours AnchoredFragment (HeaderWithTime blk)
cand
      -- 1. The ChainDB maintains the invariant that the anchor of our fragment
      --    corresponds to the immutable tip.
      --
      -- 2. The ChainSync client locally maintains the invariant that our
      --    fragment and the candidate fragment have the same anchor point. This
      --    establishes the precondition required by @preferAnchoredCandidate@.
      --
      -- 3. However, by the time that the BlockFetch logic processes a fragment
      --    presented to it by the ChainSync client, our current fragment might
      --    have changed, and they might no longer be anchored at the same
      --    point. This means that we are no longer guaranteed that the
      --    precondition holds.
      --
      -- 4. Our chain's anchor can only move forward. We can detect this by
      --    looking at the block/slot numbers of the anchors: When the anchor
      --    advances, either the block number increases (usual case), or the
      --    block number stays the same, but the slot number increases (EBB
      --    case).
      --
      | AnchoredFragment (HeaderWithTime blk)
-> (WithOrigin BlockNo, WithOrigin SlotNo)
anchorBlockNoAndSlot AnchoredFragment (HeaderWithTime blk)
cand (WithOrigin BlockNo, WithOrigin SlotNo)
-> (WithOrigin BlockNo, WithOrigin SlotNo) -> Bool
forall a. Ord a => a -> a -> Bool
< AnchoredFragment (HeaderWithTime blk)
-> (WithOrigin BlockNo, WithOrigin SlotNo)
anchorBlockNoAndSlot AnchoredFragment (HeaderWithTime blk)
ours  -- (4)
      = case (AnchoredFragment (HeaderWithTime blk) -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment (HeaderWithTime blk)
ours, AnchoredFragment (HeaderWithTime blk) -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment (HeaderWithTime blk)
cand) of
          -- Both are non-empty, the precondition trivially holds.
          (Bool
False, Bool
False) -> BlockConfig blk
-> AnchoredFragment (HeaderWithTime 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 BlockConfig blk
bcfg AnchoredFragment (HeaderWithTime blk)
ours AnchoredFragment (HeaderWithTime blk)
cand
          -- The candidate is shorter than our chain and, worse, we'd have to
          -- roll back past our immutable tip (the anchor of @cand@).
          (Bool
_,     Bool
True)  -> Bool
False
          -- As argued above we can only reach this case when our chain's anchor
          -- has changed (4).
          --
          -- It is impossible for our chain to change /and/ still be empty: the
          -- anchor of our chain only changes when a new block becomes
          -- immutable. For a new block to become immutable, we must have
          -- extended our chain with at least @k + 1@ blocks. Which means our
          -- fragment can't be empty.
          (Bool
True,  Bool
_)     -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"

      | Bool
otherwise
      = BlockConfig blk
-> AnchoredFragment (HeaderWithTime 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 BlockConfig blk
bcfg AnchoredFragment (HeaderWithTime blk)
ours AnchoredFragment (HeaderWithTime blk)
cand
      where
        anchorBlockNoAndSlot ::
             AnchoredFragment (HeaderWithTime blk)
          -> (WithOrigin BlockNo, WithOrigin SlotNo)
        anchorBlockNoAndSlot :: AnchoredFragment (HeaderWithTime blk)
-> (WithOrigin BlockNo, WithOrigin SlotNo)
anchorBlockNoAndSlot AnchoredFragment (HeaderWithTime blk)
frag =
            (Anchor (HeaderWithTime blk) -> WithOrigin BlockNo
forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor (HeaderWithTime blk)
a, Anchor (HeaderWithTime blk) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
AF.anchorToSlotNo Anchor (HeaderWithTime blk)
a)
          where
            a :: Anchor (HeaderWithTime blk)
a = AnchoredFragment (HeaderWithTime blk)
-> Anchor (HeaderWithTime blk)
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment (HeaderWithTime blk)
frag

    compareCandidateChains :: AnchoredFragment (HeaderWithTime blk)
                           -> AnchoredFragment (HeaderWithTime blk)
                           -> Ordering
    compareCandidateChains :: AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk) -> Ordering
compareCandidateChains = BlockConfig blk
-> AnchoredFragment (HeaderWithTime blk)
-> AnchoredFragment (HeaderWithTime blk)
-> Ordering
forall blk (h :: * -> *).
(BlockSupportsProtocol blk, HasCallStack, GetHeader1 h,
 HasHeader (h blk)) =>
BlockConfig blk
-> AnchoredFragment (h blk) -> AnchoredFragment (h blk) -> Ordering
compareAnchoredFragments BlockConfig blk
bcfg

    headerForgeUTCTime :: FromConsensus (HeaderWithTime blk) -> STM m UTCTime
    headerForgeUTCTime :: FromConsensus (HeaderWithTime blk) -> STM m UTCTime
headerForgeUTCTime  = UTCTime -> STM m UTCTime
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        (UTCTime -> STM m UTCTime)
-> (FromConsensus (HeaderWithTime blk) -> UTCTime)
-> FromConsensus (HeaderWithTime blk)
-> STM m UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemStart -> RelativeTime -> UTCTime
fromRelativeTime (BlockConfig blk -> SystemStart
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> SystemStart
SupportsNode.getSystemStart BlockConfig blk
bcfg)
                        (RelativeTime -> UTCTime)
-> (FromConsensus (HeaderWithTime blk) -> RelativeTime)
-> FromConsensus (HeaderWithTime blk)
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderWithTime blk -> RelativeTime
forall blk. HeaderWithTime blk -> RelativeTime
hwtSlotRelativeTime
                        (HeaderWithTime blk -> RelativeTime)
-> (FromConsensus (HeaderWithTime blk) -> HeaderWithTime blk)
-> FromConsensus (HeaderWithTime blk)
-> RelativeTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromConsensus (HeaderWithTime blk) -> HeaderWithTime blk
forall a. FromConsensus a -> a
unFromConsensus

    readChainSelStarvation :: STM m ChainSelStarvation
readChainSelStarvation = ChainDbView m blk -> STM m ChainSelStarvation
forall (m :: * -> *) blk.
ChainDbView m blk -> STM m ChainSelStarvation
getChainSelStarvation ChainDbView m blk
chainDB

    demoteChainSyncJumpingDynamo :: peer -> m ()
    demoteChainSyncJumpingDynamo :: peer -> m ()
demoteChainSyncJumpingDynamo = Tracer m (TraceEventDbf peer)
-> ChainSyncClientHandleCollection peer m blk -> peer -> m ()
forall peer blk (m :: * -> *).
(Ord peer, LedgerSupportsProtocol blk, MonadSTM m) =>
Tracer m (TraceEventDbf peer)
-> ChainSyncClientHandleCollection peer m blk -> peer -> m ()
CSJumping.rotateDynamo Tracer m (TraceEventDbf peer)
csjTracer ChainSyncClientHandleCollection peer m blk
csHandlesCol