From db39d20d4e941af1edf4337db0e84448145571a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 5 Jun 2024 10:15:13 +0000 Subject: [PATCH 001/136] Split the `BlockFetch.Decision` module --- ouroboros-network/ouroboros-network.cabal | 3 + .../Ouroboros/Network/BlockFetch/Decision.hs | 1136 +---------------- .../Network/BlockFetch/Decision/BulkSync.hs | 30 + .../Network/BlockFetch/Decision/Common.hs | 193 +++ .../Network/BlockFetch/Decision/Deadline.hs | 969 ++++++++++++++ 5 files changed, 1224 insertions(+), 1107 deletions(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs create mode 100644 ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs create mode 100644 ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 12bf433f52d..75957e35208 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -33,6 +33,9 @@ library Ouroboros.Network.BlockFetch.ClientRegistry Ouroboros.Network.BlockFetch.ClientState Ouroboros.Network.BlockFetch.Decision + Ouroboros.Network.BlockFetch.Decision.BulkSync + Ouroboros.Network.BlockFetch.Decision.Common + Ouroboros.Network.BlockFetch.Decision.Deadline Ouroboros.Network.BlockFetch.DeltaQ Ouroboros.Network.BlockFetch.State Ouroboros.Network.DeltaQ diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index de652e1f53e..dffdfdb8398 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -23,229 +23,15 @@ module Ouroboros.Network.BlockFetch.Decision , fetchRequestDecisions ) where -import Data.Set qualified as Set - -import Data.Function (on) import Data.Hashable -import Data.List (foldl', groupBy, sortBy, transpose) -import Data.Maybe (mapMaybe) -import Data.Set (Set) -import GHC.Stack (HasCallStack) - -import Control.Exception (assert) -import Control.Monad (guard) -import Control.Monad.Class.MonadTime.SI (DiffTime) - -import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq (..)) -import Ouroboros.Network.AnchoredFragment qualified as AF +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block -import Ouroboros.Network.Point (withOriginToMaybe) - -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), - PeerFetchInFlight (..), PeerFetchStatus (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) -import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), - PeerGSV (..), SizeInBytes, calculatePeerFetchInFlightLimits, - comparePeerGSV, comparePeerGSV', estimateExpectedResponseDuration, - estimateResponseDeadlineProbability) - - -data FetchDecisionPolicy header = FetchDecisionPolicy { - maxInFlightReqsPerPeer :: Word, -- A protocol constant. - - maxConcurrencyBulkSync :: Word, - maxConcurrencyDeadline :: Word, - decisionLoopInterval :: DiffTime, - peerSalt :: Int, - - plausibleCandidateChain :: HasCallStack - => AnchoredFragment header - -> AnchoredFragment header -> Bool, - - compareCandidateChains :: HasCallStack - => AnchoredFragment header - -> AnchoredFragment header - -> Ordering, - - blockFetchSize :: header -> SizeInBytes - } - - -type PeerInfo header peer extra = - ( PeerFetchStatus header, - PeerFetchInFlight header, - PeerGSV, - peer, - extra - ) - --- | Throughout the decision making process we accumulate reasons to decline --- to fetch any blocks. This type is used to wrap intermediate and final --- results. --- -type FetchDecision result = Either FetchDecline result - --- | All the various reasons we can decide not to fetch blocks from a peer. --- --- It is worth highlighting which of these reasons result from competition --- among upstream peers. --- --- * 'FetchDeclineInFlightOtherPeer': decline this peer because all the --- unfetched blocks of its candidate chain have already been requested from --- other peers. This reason reflects the least-consequential competition --- among peers: the competition that determines merely which upstream peer to --- burden with the request (eg the one with the best --- 'Ouroboros.Network.BlockFetch.DeltaQ.DeltaQ' metrics). The consequences --- are relatively minor because the unfetched blocks on this peer's candidate --- chain will be requested regardless; it's merely a question of "From who?". --- (One exception: if an adversarial peer wins this competition such that the --- blocks are only requested from them, then it may be possible that this --- decision determines whether the blocks are ever /received/. But that --- depends on details of timeouts, a longer competing chain being soon --- received within those timeouts, and so on.) --- --- * 'FetchDeclineChainNotPlausible': decline this peer because the node has --- already fetched, validated, and selected a chain better than its candidate --- chain from other peers (or from the node's own block forge). Because the --- node's current selection is influenced by what blocks other peers have --- recently served (or it recently minted), this reason reflects that peers --- /indirectly/ compete by serving as long of a chain as possible and as --- promptly as possible. When the tips of the peers' selections are all --- within their respective forecast horizons (see --- 'Ouroboros.Consensus.Ledger.SupportsProtocol.ledgerViewForecastAt'), then --- the length of their candidate chains will typically be the length of their --- selections, since the ChainSync is free to race ahead (in contrast, the --- BlockFetch pipeline depth is bounded such that it will, for a syncing --- node, not be able to request all blocks between the selection and the end --- of the forecast window). But if one or more of their tips is beyond the --- horizon, then the relative length of the candidate chains is more --- complicated, influenced by both the relative density of the chains' --- suffixes and the relative age of the chains' intersection with the node's --- selection (since each peer's forecast horizon is a fixed number of slots --- after the candidate's successor of that intersection). --- --- * 'FetchDeclineConcurrencyLimit': decline this peer while the node has --- already fully allocated the artificially scarce 'maxConcurrentFetchPeers' --- resource amongst its other peers. This reason reflects the --- least-fundamental competition: it's the only way a node would decline a --- candidate chain C that it would immediately switch to if C had somehow --- already been fetched (and any better current candidates hadn't). It is --- possible that this peer's candidate fragment is better than the candidate --- fragments of other peers, but that should only happen ephemerally (eg for --- a brief while immediately after first connecting to this peer). --- --- * 'FetchDeclineChainIntersectionTooDeep': decline this peer because the node's --- selection has more than @K@ blocks that are not on this peer's candidate --- chain. Typically, this reason occurs after the node has been declined---ie --- lost the above competitions---for a long enough duration. This decision --- only arises if the BlockFetch decision logic wins a harmless race against --- the ChainSync client once the node's selection gets longer, since --- 'Ouroboros.Consensus.MiniProtocol.ChainSync.Client.ForkTooDeep' --- disconnects from such a peer. --- -data FetchDecline = - -- | This peer's candidate chain is not longer than our chain. For more - -- details see - -- 'Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface.mkBlockFetchConsensusInterface' - -- which implements 'plausibleCandidateChain'. - -- - FetchDeclineChainNotPlausible - - -- | Switching to this peer's candidate chain would require rolling back - -- more than @K@ blocks. - -- - | FetchDeclineChainIntersectionTooDeep - - -- | Every block on this peer's candidate chain has already been fetched. - -- - | FetchDeclineAlreadyFetched - - -- | This peer's candidate chain has already been requested from this - -- peer. - -- - | FetchDeclineInFlightThisPeer - - -- | Some blocks on this peer's candidate chain have not yet been fetched, - -- but all of those have already been requested from other peers. - -- - | FetchDeclineInFlightOtherPeer - - -- | This peer's BlockFetch client is shutting down, see - -- 'PeerFetchStatusShutdown'. - -- - | FetchDeclinePeerShutdown - - -- | Blockfetch is starting up and waiting on corresponding Chainsync. - | FetchDeclinePeerStarting - - - -- The reasons above this comment are fundamental and/or obvious. On the - -- other hand, the reasons below are heuristic. - - - -- | This peer is in a potentially-temporary state in which it has not - -- responded to us within a certain expected time limit, see - -- 'PeerFetchStatusAberrant'. - -- - | FetchDeclinePeerSlow - - -- | This peer is not under the 'maxInFlightReqsPerPeer' limit. - -- - -- The argument is the 'maxInFlightReqsPerPeer' constant. - -- - | FetchDeclineReqsInFlightLimit !Word - - -- | This peer is not under the 'inFlightBytesHighWatermark' bytes limit. - -- - -- The arguments are: - -- - -- * number of bytes currently in flight for that peer - -- * the configured 'inFlightBytesLowWatermark' constant - -- * the configured 'inFlightBytesHighWatermark' constant - -- - | FetchDeclineBytesInFlightLimit !SizeInBytes !SizeInBytes !SizeInBytes - - -- | This peer is not under the 'inFlightBytesLowWatermark'. - -- - -- The arguments are: - -- - -- * number of bytes currently in flight for that peer - -- * the configured 'inFlightBytesLowWatermark' constant - -- * the configured 'inFlightBytesHighWatermark' constant - -- - | FetchDeclinePeerBusy !SizeInBytes !SizeInBytes !SizeInBytes - - -- | The node is not under the 'maxConcurrentFetchPeers' limit. - -- - -- The arguments are: - -- - -- * the current 'FetchMode' - -- * the corresponding configured limit constant, either - -- 'maxConcurrencyBulkSync' or 'maxConcurrencyDeadline' - -- - | FetchDeclineConcurrencyLimit !FetchMode !Word - deriving (Eq, Show) - - --- | The \"oh noes?!\" operator. --- --- In the case of an error, the operator provides a specific error value. --- -(?!) :: Maybe a -> e -> Either e a -Just x ?! _ = Right x -Nothing ?! e = Left e - --- | The combination of a 'ChainSuffix' and a list of discontiguous --- 'AnchoredFragment's: --- --- * When comparing two 'CandidateFragments' as candidate chains, we use the --- 'ChainSuffix'. --- --- * To track which blocks of that candidate still have to be downloaded, we --- use a list of discontiguous 'AnchoredFragment's. --- -type CandidateFragments header = (ChainSuffix header, [AnchoredFragment header]) +import Ouroboros.Network.BlockFetch.Decision.Common +import Ouroboros.Network.BlockFetch.Decision.Deadline +import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSync) fetchDecisions :: (Ord peer, @@ -259,893 +45,29 @@ fetchDecisions -> MaxSlotNo -> [(AnchoredFragment header, PeerInfo header peer extra)] -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] -fetchDecisions fetchDecisionPolicy@FetchDecisionPolicy { - plausibleCandidateChain, - compareCandidateChains, - blockFetchSize, - peerSalt - } - fetchMode - currentChain - fetchedBlocks - fetchedMaxSlotNo = - - -- Finally, make a decision for each (chain, peer) pair. - fetchRequestDecisions - fetchDecisionPolicy - fetchMode - . map swizzleSIG - - -- Filter to keep blocks that are not already in-flight with other peers. - . filterNotAlreadyInFlightWithOtherPeers - fetchMode - . map swizzleSI - - -- Reorder chains based on consensus policy and network timing data. - . prioritisePeerChains - fetchMode - peerSalt - compareCandidateChains - blockFetchSize - . map swizzleIG - - -- Filter to keep blocks that are not already in-flight for this peer. - . filterNotAlreadyInFlightWithPeer - . map swizzleI - - -- Filter to keep blocks that have not already been downloaded. - . filterNotAlreadyFetched - fetchedBlocks - fetchedMaxSlotNo - - -- Select the suffix up to the intersection with the current chain. - . selectForkSuffixes - currentChain - - -- First, filter to keep chains the consensus layer tells us are plausible. - . filterPlausibleCandidates - plausibleCandidateChain - currentChain - where - -- Data swizzling functions to get the right info into each stage. - swizzleI (c, p@(_, inflight,_,_, _)) = (c, inflight, p) - swizzleIG (c, p@(_, inflight,gsvs,peer,_)) = (c, inflight, gsvs, peer, p) - swizzleSI (c, p@(status,inflight,_,_, _)) = (c, status, inflight, p) - swizzleSIG (c, p@(status,inflight,gsvs,peer,_)) = (c, status, inflight, gsvs, peer, p) - -{- -We have the node's /current/ or /adopted/ chain. This is the node's chain in -the sense specified by the Ouroboros algorithm. It is a fully verified chain -with block bodies and a ledger state. - - ┆ ┆ - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ │ - ───┴───┴─── current chain length (block number) - -With chain selection we are interested in /candidate/ chains. We have these -candidate chains in the form of chains of verified headers, but without bodies. - -The consensus layer gives us the current set of candidate chains from our peers -and we have the task of selecting which block bodies to download, and then -passing those block bodes back to the consensus layer. The consensus layer will -try to validate them and decide if it wants to update its current chain. - - ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ └───┘ - │ │ │ │ │ │ │ │ - ───┴───┴─────┼───┼─────┼───┼─────┼───┼───────────── current chain length - │ │ │ │ │ │ - current ├───┤ ├───┤ └───┘ - (blocks) │ │ │ │ - └───┘ └───┘ - A B C D - candidates - (headers) - -In this example we have four candidate chains, with all but chain D strictly -longer than our current chain. - -In general there are many candidate chains. We make a distinction between a -candidate chain and the peer from which it is available. It is often the -case that the same chain is available from multiple peers. We will try to be -clear about when we are referring to chains or the combination of a chain and -the peer from which it is available. - -For the sake of the example let us assume we have the four chains above -available from the following peers. - -peer 1 2 3 4 5 6 7 - ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ └───┘ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ │ │ - ──┼───┼─────┼───┼─────┼───┼─────┼───┼───────────────┼───┼─────┼───┼── - │ │ │ │ │ │ │ │ │ │ │ │ - └───┘ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - └───┘ └───┘ └───┘ └───┘ └───┘ -chain C A B A D B A - -This is the form in which we are informed about candidate chains from the -consensus layer, the combination of a chain and the peer it is from. This -makes sense, since these things change independently. - -We will process the chains in this form, keeping the peer/chain combination all -the way through. Although there could in principle be some opportunistic saving -by sharing when multiple peers provide the same chain, taking advantage of this -adds complexity and does nothing to improve our worst case costs. - -We are only interested in candidate chains that are strictly longer than our -current chain. So our first task is to filter down to this set. --} - - --- | Keep only those candidate chains that are preferred over the current --- chain. Typically, this means that their length is longer than the length of --- the current chain. --- -filterPlausibleCandidates - :: (AnchoredFragment block -> AnchoredFragment header -> Bool) - -> AnchoredFragment block -- ^ The current chain - -> [(AnchoredFragment header, peerinfo)] - -> [(FetchDecision (AnchoredFragment header), peerinfo)] -filterPlausibleCandidates plausibleCandidateChain currentChain chains = - [ (chain', peer) - | (chain, peer) <- chains - , let chain' = do - guard (plausibleCandidateChain currentChain chain) - ?! FetchDeclineChainNotPlausible - return chain - ] - - -{- -In the example, this leaves us with only the candidate chains: A, B and C, but -still paired up with the various peers. - - -peer 1 2 3 4 6 7 - ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ │ │ - ──┼───┼─────┼───┼─────┼───┼─────┼───┼───────────────┼───┼─────┼───┼── - │ │ │ │ │ │ │ │ │ │ │ │ - └───┘ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - └───┘ └───┘ └───┘ └───┘ └───┘ -chain C A B A B A --} - - -{- -Of course we would at most need to download the blocks in a candidate chain -that are not already in the current chain. So we must find those intersections. - -Before we do that, lets define how we represent a suffix of a chain. We do this -very simply as a chain fragment: exactly those blocks contained in the suffix. -A chain fragment is of course not a chain, but has many similar invariants. - -We will later also need to represent chain ranges when we send block fetch -requests. We do this using a pair of points: the first and last blocks in the -range. While we can represent an empty chain fragment, we cannot represent an -empty fetch range, but this is ok since we never request empty ranges. - - Chain fragment - ┌───┐ - │ ◉ │ Start of range, inclusive - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ ◉ │ End of range, inclusive. - └───┘ --} - --- | A chain suffix, obtained by intersecting a candidate chain with the --- current chain. --- --- The anchor point of a 'ChainSuffix' will be a point within the bounds of --- the current chain ('AF.withinFragmentBounds'), indicating that it forks off --- in the last @K@ blocks. --- --- A 'ChainSuffix' must be non-empty, as an empty suffix, i.e. the candidate --- chain is equal to the current chain, would not be a plausible candidate. -newtype ChainSuffix header = - ChainSuffix { getChainSuffix :: AnchoredFragment header } - -{- -We define the /chain suffix/ as the suffix of the candidate chain up until (but -not including) where it intersects the current chain. - - - current peer 1 peer 2 - - ┆ ┆ - ├───┤ - │ ◀┿━━━━━━━━━━━━━━━━━┓ - ├───┤ ┌─╂─┐ - │ │ │ ◉ │ - ├───┤ ├───┤ - │ │ │ │ - ├───┤ ├───┤ - │ ◀┿━━━━━━━┓ │ │ - ───┴───┴─────┬─╂─┬─────┼───┼─── - │ ◉ │ │ │ - └───┘ ├───┤ - │ ◉ │ - └───┘ - C A - -In this example we found that C was a strict extension of the current chain -and chain A was a short fork. - -Note that it's possible that we don't find any intersection within the last K -blocks. This means the candidate forks by more than K and so we are not -interested in this candidate at all. --} - --- | Find the chain suffix for a candidate chain, with respect to the --- current chain. --- -chainForkSuffix - :: (HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) - => AnchoredFragment block -- ^ Current chain. - -> AnchoredFragment header -- ^ Candidate chain - -> Maybe (ChainSuffix header) -chainForkSuffix current candidate = - case AF.intersect current candidate of - Nothing -> Nothing - Just (_, _, _, candidateSuffix) -> - -- If the suffix is empty, it means the candidate chain was equal to - -- the current chain and didn't fork off. Such a candidate chain is - -- not a plausible candidate, so it must have been filtered out. - assert (not (AF.null candidateSuffix)) $ - Just (ChainSuffix candidateSuffix) - -selectForkSuffixes - :: (HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) - => AnchoredFragment block - -> [(FetchDecision (AnchoredFragment header), peerinfo)] - -> [(FetchDecision (ChainSuffix header), peerinfo)] -selectForkSuffixes current chains = - [ (mchain', peer) - | (mchain, peer) <- chains - , let mchain' = do - chain <- mchain - chainForkSuffix current chain ?! FetchDeclineChainIntersectionTooDeep - ] - -{- -We define the /fetch range/ as the suffix of the fork range that has not yet -had its blocks downloaded and block content checked against the headers. - ┆ ┆ - ├───┤ - │ │ - ├───┤ ┌───┐ - │ │ already │ │ - ├───┤ fetched ├───┤ - │ │ blocks │ │ - ├───┤ ├───┤ - │ │ │░◉░│ ◄ fetch range - ───┴───┴─────┬───┬─────┼───┼─── - │░◉░│ ◄ │░░░│ - └───┘ ├───┤ - │░◉░│ ◄ - └───┘ - -In earlier versions of this scheme we maintained and relied on the invariant -that the ranges of fetched blocks are backwards closed. This meant we never had -discontinuous ranges of fetched or not-yet-fetched blocks. This invariant does -simplify things somewhat by keeping the ranges continuous however it precludes -fetching ranges of blocks from different peers in parallel. - -We do not maintain any such invariant and so we have to deal with there being -gaps in the ranges we have already fetched or are yet to fetch. To keep the -tracking simple we do not track the ranges themselves, rather we track the set -of individual blocks without their relationship to each other. - --} - --- | Find the fragments of the chain suffix that we still need to fetch, these --- are the fragments covering blocks that have not yet been fetched and are --- not currently in the process of being fetched from this peer. --- --- Typically this is a single fragment forming a suffix of the chain, but in --- the general case we can get a bunch of discontiguous chain fragments. --- -filterNotAlreadyFetched - :: (HasHeader header, HeaderHash header ~ HeaderHash block) - => (Point block -> Bool) - -> MaxSlotNo - -> [(FetchDecision (ChainSuffix header), peerinfo)] - -> [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo chains = - [ (mcandidates, peer) - | (mcandidate, peer) <- chains - , let mcandidates = do - candidate <- mcandidate - let fragments = filterWithMaxSlotNo - notAlreadyFetched - fetchedMaxSlotNo - (getChainSuffix candidate) - guard (not (null fragments)) ?! FetchDeclineAlreadyFetched - return (candidate, fragments) - ] - where - notAlreadyFetched = not . alreadyDownloaded . castPoint . blockPoint - - -filterNotAlreadyInFlightWithPeer - :: HasHeader header - => [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, - peerinfo)] - -> [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyInFlightWithPeer chains = - [ (mcandidatefragments', peer) - | (mcandidatefragments, inflight, peer) <- chains - , let mcandidatefragments' = do - (candidate, chainfragments) <- mcandidatefragments - let fragments = concatMap (filterWithMaxSlotNo - (notAlreadyInFlight inflight) - (peerFetchMaxSlotNo inflight)) - chainfragments - guard (not (null fragments)) ?! FetchDeclineInFlightThisPeer - return (candidate, fragments) - ] - where - notAlreadyInFlight inflight b = - blockPoint b `Set.notMember` peerFetchBlocksInFlight inflight - - --- | A penultimate step of filtering, but this time across peers, rather than --- individually for each peer. If we're following the parallel fetch --- mode then we filter out blocks that are already in-flight with other --- peers. --- --- Note that this does /not/ cover blocks that are proposed to be fetched in --- this round of decisions. That step is covered in 'fetchRequestDecisions'. --- -filterNotAlreadyInFlightWithOtherPeers - :: HasHeader header - => FetchMode - -> [( FetchDecision [AnchoredFragment header] - , PeerFetchStatus header - , PeerFetchInFlight header - , peerinfo )] - -> [(FetchDecision [AnchoredFragment header], peerinfo)] - -filterNotAlreadyInFlightWithOtherPeers FetchModeDeadline chains = - [ (mchainfragments, peer) - | (mchainfragments, _, _, peer) <- chains ] - -filterNotAlreadyInFlightWithOtherPeers FetchModeBulkSync chains = - [ (mcandidatefragments', peer) - | (mcandidatefragments, _, _, peer) <- chains - , let mcandidatefragments' = do - chainfragments <- mcandidatefragments - let fragments = concatMap (filterWithMaxSlotNo - notAlreadyInFlight - maxSlotNoInFlightWithOtherPeers) - chainfragments - guard (not (null fragments)) ?! FetchDeclineInFlightOtherPeer - return fragments - ] - where - notAlreadyInFlight b = - blockPoint b `Set.notMember` blocksInFlightWithOtherPeers - - -- All the blocks that are already in-flight with all peers - blocksInFlightWithOtherPeers = - Set.unions - [ case status of - PeerFetchStatusShutdown -> Set.empty - PeerFetchStatusStarting -> Set.empty - PeerFetchStatusAberrant -> Set.empty - _other -> peerFetchBlocksInFlight inflight - | (_, status, inflight, _) <- chains ] - - -- The highest slot number that is or has been in flight for any peer. - maxSlotNoInFlightWithOtherPeers = foldl' max NoMaxSlotNo - [ peerFetchMaxSlotNo inflight | (_, _, inflight, _) <- chains ] - --- | Filter a fragment. This is an optimised variant that will behave the same --- as 'AnchoredFragment.filter' if the following precondition is satisfied: --- --- PRECONDITION: for all @hdr@ in the chain fragment: if @blockSlot hdr > --- maxSlotNo@ then the predicate should not hold for any header after @hdr@ in --- the chain fragment. --- --- For example, when filtering out already downloaded blocks from the --- fragment, it does not make sense to keep filtering after having encountered --- the highest slot number the ChainDB has seen so far: blocks with a greater --- slot number cannot have been downloaded yet. When the candidate fragments --- get far ahead of the current chain, e.g., @2k@ headers, this optimisation --- avoids the linear cost of filtering these headers when we know in advance --- they will all remain in the final fragment. In case the given slot number --- is 'NoSlotNo', no filtering takes place, as there should be no matches --- because we haven't downloaded any blocks yet. --- --- For example, when filtering out blocks already in-flight for the given --- peer, the given @maxSlotNo@ can correspond to the block with the highest --- slot number that so far has been in-flight for the given peer. When no --- blocks have been in-flight yet, @maxSlotNo@ can be 'NoSlotNo', in which --- case no filtering needs to take place, which makes sense, as there are no --- blocks to filter out. Note that this is conservative: if a block is for --- some reason multiple times in-flight (maybe it has to be redownloaded) and --- the block's slot number matches the @maxSlotNo@, it will now be filtered --- (while the filtering might previously have stopped before encountering the --- block in question). This is fine, as the filter will now include the block, --- because according to the filtering predicate, the block is not in-flight. -filterWithMaxSlotNo - :: forall header. HasHeader header - => (header -> Bool) - -> MaxSlotNo -- ^ @maxSlotNo@ - -> AnchoredFragment header - -> [AnchoredFragment header] -filterWithMaxSlotNo p maxSlotNo = - AF.filterWithStop p ((> maxSlotNo) . MaxSlotNo . blockSlot) - -prioritisePeerChains - :: forall extra header peer. - ( HasHeader header - , Hashable peer - , Ord peer - ) - => FetchMode - -> Int - -> (AnchoredFragment header -> AnchoredFragment header -> Ordering) - -> (header -> SizeInBytes) - -> [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, - PeerGSV, - peer, - extra )] - -> [(FetchDecision [AnchoredFragment header], extra)] -prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSize = - map (\(decision, peer) -> - (fmap (\(_,_,fragment) -> fragment) decision, peer)) - . concatMap ( concat - . transpose - . groupBy (equatingFst - (equatingRight - ((==) `on` chainHeadPoint))) - . sortBy (comparingFst - (comparingRight - (compare `on` chainHeadPoint))) - ) - . groupBy (equatingFst - (equatingRight - (equatingPair - -- compare on probability band first, then preferred chain - (==) - (equateCandidateChains `on` getChainSuffix) - `on` - (\(band, chain, _fragments) -> (band, chain))))) - . sortBy (descendingOrder - (comparingFst - (comparingRight - (comparingPair - -- compare on probability band first, then preferred chain - compare - (compareCandidateChains `on` getChainSuffix) - `on` - (\(band, chain, _fragments) -> (band, chain)))))) - . map annotateProbabilityBand - . sortBy (\(_,_,a,ap,_) (_,_,b,bp,_) -> - comparePeerGSV' salt (a,ap) (b,bp)) - where - annotateProbabilityBand (Left decline, _, _, _, peer) = (Left decline, peer) - annotateProbabilityBand (Right (chain,fragments), inflight, gsvs, _, peer) = - (Right (band, chain, fragments), peer) - where - band = probabilityBand $ - estimateResponseDeadlineProbability - gsvs - (peerFetchBytesInFlight inflight) - (totalFetchSize blockFetchSize fragments) - deadline - - deadline = 2 -- seconds -- TODO: get this from external info - - equateCandidateChains chain1 chain2 - | EQ <- compareCandidateChains chain1 chain2 = True - | otherwise = False - - chainHeadPoint (_,ChainSuffix c,_) = AF.headPoint c - -prioritisePeerChains FetchModeBulkSync salt compareCandidateChains blockFetchSize = - map (\(decision, peer) -> - (fmap (\(_, _, fragment) -> fragment) decision, peer)) - . sortBy (comparingFst - (comparingRight - (comparingPair - -- compare on preferred chain first, then duration - (compareCandidateChains `on` getChainSuffix) - compare - `on` - (\(duration, chain, _fragments) -> (chain, duration))))) - . map annotateDuration - . sortBy (\(_,_,a,ap,_) (_,_,b,bp,_) -> - comparePeerGSV' salt (a,ap) (b,bp)) - where - annotateDuration (Left decline, _, _, _, peer) = (Left decline, peer) - annotateDuration (Right (chain,fragments), inflight, gsvs, _, peer) = - (Right (duration, chain, fragments), peer) - where - -- TODO: consider if we should put this into bands rather than just - -- taking the full value. - duration = estimateExpectedResponseDuration - gsvs - (peerFetchBytesInFlight inflight) - (totalFetchSize blockFetchSize fragments) - -totalFetchSize :: (header -> SizeInBytes) - -> [AnchoredFragment header] - -> SizeInBytes -totalFetchSize blockFetchSize fragments = - sum [ blockFetchSize header - | fragment <- fragments - , header <- AF.toOldestFirst fragment ] - -type Comparing a = a -> a -> Ordering -type Equating a = a -> a -> Bool - -descendingOrder :: Comparing a -> Comparing a -descendingOrder cmp = flip cmp - -comparingPair :: Comparing a -> Comparing b -> Comparing (a, b) -comparingPair cmpA cmpB (a1, b1) (a2, b2) = cmpA a1 a2 <> cmpB b1 b2 - -equatingPair :: Equating a -> Equating b -> Equating (a, b) -equatingPair eqA eqB (a1, b1) (a2, b2) = eqA a1 a2 && eqB b1 b2 - -comparingEither :: Comparing a -> Comparing b -> Comparing (Either a b) -comparingEither _ _ (Left _) (Right _) = LT -comparingEither cmpA _ (Left x) (Left y) = cmpA x y -comparingEither _ cmpB (Right x) (Right y) = cmpB x y -comparingEither _ _ (Right _) (Left _) = GT - -equatingEither :: Equating a -> Equating b -> Equating (Either a b) -equatingEither _ _ (Left _) (Right _) = False -equatingEither eqA _ (Left x) (Left y) = eqA x y -equatingEither _ eqB (Right x) (Right y) = eqB x y -equatingEither _ _ (Right _) (Left _) = False - -comparingFst :: Comparing a -> Comparing (a, b) -comparingFst cmp = cmp `on` fst - -equatingFst :: Equating a -> Equating (a, b) -equatingFst eq = eq `on` fst - -comparingRight :: Comparing b -> Comparing (Either a b) -comparingRight = comparingEither mempty - -equatingRight :: Equating b -> Equating (Either a b) -equatingRight = equatingEither (\_ _ -> True) - --- | Given the probability of the download completing within the deadline, --- classify that into one of three broad bands: high, medium and low. --- --- The bands are --- --- * high: 98% -- 100% --- * medium: 75% -- 98% --- * low: 0% -- 75% --- -probabilityBand :: Double -> ProbabilityBand -probabilityBand p - | p > 0.98 = ProbabilityHigh - | p > 0.75 = ProbabilityModerate - | otherwise = ProbabilityLow - -- TODO: for hysteresis, increase probability if we're already using this peer - -data ProbabilityBand = ProbabilityLow - | ProbabilityModerate - | ProbabilityHigh - deriving (Eq, Ord, Show) - - -{- -In the second phase we walk over the prioritised fetch suffixes for each peer -and make a decision about whether we should initiate any new fetch requests. - -This decision is based on a number of factors: - - * Is the fetch suffix empty? If so, there's nothing to do. - * Do we already have block fetch requests in flight with this peer? - * If so are we under the maximum number of in-flight blocks for this peer? - * Is this peer still performing within expectations or has it missed any soft - time outs? - * Has the peer missed any hard timeouts or otherwise been disconnected. - * Are we at our soft or hard limit of the number of peers we are prepared to - fetch blocks from concurrently? - -We look at each peer chain fetch suffix one by one. Of course decisions we -make earlier can affect decisions later, in particular the number of peers we -fetch from concurrently can increase if we fetch from a new peer, and we must -obviously take that into account when considering later peer chains. --} - - -fetchRequestDecisions - :: forall extra header peer. - ( Hashable peer - , HasHeader header - , Ord peer - ) - => FetchDecisionPolicy header - -> FetchMode - -> [( FetchDecision [AnchoredFragment header] - , PeerFetchStatus header - , PeerFetchInFlight header - , PeerGSV - , peer - , extra)] - -> [(FetchDecision (FetchRequest header), extra)] -fetchRequestDecisions fetchDecisionPolicy fetchMode chains = - go nConcurrentFetchPeers0 Set.empty NoMaxSlotNo chains - where - go :: Word - -> Set (Point header) - -> MaxSlotNo - -> [(Either FetchDecline [AnchoredFragment header], - PeerFetchStatus header, PeerFetchInFlight header, PeerGSV, peer, extra)] - -> [(FetchDecision (FetchRequest header), extra)] - go !_ !_ !_ [] = [] - go !nConcurrentFetchPeers !blocksFetchedThisRound !maxSlotNoFetchedThisRound - ((mchainfragments, status, inflight, gsvs, peer, extra) : cps) = - - (decision, extra) - : go nConcurrentFetchPeers' blocksFetchedThisRound' - maxSlotNoFetchedThisRound' cps - where - decision = fetchRequestDecision - fetchDecisionPolicy - fetchMode - -- Permit the preferred peers to by pass any concurrency limits. - (if elem peer nPreferedPeers then 0 - else nConcurrentFetchPeers) - (calculatePeerFetchInFlightLimits gsvs) - inflight - status - mchainfragments' - - mchainfragments' = - case fetchMode of - FetchModeDeadline -> mchainfragments - FetchModeBulkSync -> do - chainfragments <- mchainfragments - let fragments = - concatMap (filterWithMaxSlotNo - notFetchedThisRound - maxSlotNoFetchedThisRound) - chainfragments - guard (not (null fragments)) ?! FetchDeclineInFlightOtherPeer - return fragments - where - notFetchedThisRound h = - blockPoint h `Set.notMember` blocksFetchedThisRound - - nConcurrentFetchPeers' - -- increment if it was idle, and now will not be - | peerFetchReqsInFlight inflight == 0 - , Right{} <- decision = nConcurrentFetchPeers + 1 - | otherwise = nConcurrentFetchPeers - - -- This is only for avoiding duplication between fetch requests in this - -- round of decisions. Avoiding duplication with blocks that are already - -- in flight is handled by filterNotAlreadyInFlightWithOtherPeers - (blocksFetchedThisRound', maxSlotNoFetchedThisRound') = - case decision of - Left _ -> - (blocksFetchedThisRound, maxSlotNoFetchedThisRound) - Right (FetchRequest fragments) -> - (blocksFetchedThisRound `Set.union` blocksFetchedThisDecision, - maxSlotNoFetchedThisRound `max` maxSlotNoFetchedThisDecision) - where - maxSlotNoFetchedThisDecision = - foldl' max NoMaxSlotNo $ map MaxSlotNo $ - mapMaybe (withOriginToMaybe . AF.headSlot) fragments - - blocksFetchedThisDecision = - Set.fromList - [ blockPoint header - | fragment <- fragments - , header <- AF.toOldestFirst fragment ] - - nConcurrentFetchPeers0 = fromIntegral $ Set.size nActivePeers - - -- Set of peers with outstanding bytes. - nActivePeers :: Set peer - nActivePeers = - Set.fromList - . map snd - . filter (\(inFlight, _) -> inFlight > 0) - . map (\(_, _, PeerFetchInFlight{peerFetchReqsInFlight}, _, p, _) -> - (peerFetchReqsInFlight, p)) - $ chains - - -- Order the peers based on current PeerGSV. The top performing peers will be - -- permitted to go active even if we're above the desired maxConcurrentFetchPeers - -- which will cause us to switch smoothly from a slower to faster peers. - -- When switching from slow to faster peers we will be over the configured limit, but - -- PeerGSV is expected to be updated rather infrequently so the set of preferred peers should - -- be stable during 10s of seconds. - nPreferedPeers :: [peer] - nPreferedPeers = - map snd - . take (fromIntegral maxConcurrentFetchPeers) - . sortBy (\a b -> comparePeerGSV nActivePeers (peerSalt fetchDecisionPolicy) a b) - . map (\(_, _, _, gsv, p, _) -> (gsv, p)) - $ chains - - maxConcurrentFetchPeers :: Word - maxConcurrentFetchPeers = - case fetchMode of - FetchModeBulkSync -> maxConcurrencyBulkSync fetchDecisionPolicy - FetchModeDeadline -> maxConcurrencyDeadline fetchDecisionPolicy - - -fetchRequestDecision - :: HasHeader header - => FetchDecisionPolicy header - -> FetchMode - -> Word - -> PeerFetchInFlightLimits - -> PeerFetchInFlight header - -> PeerFetchStatus header - -> FetchDecision [AnchoredFragment header] - -> FetchDecision (FetchRequest header) - -fetchRequestDecision _ _ _ _ _ _ (Left decline) - = Left decline - -fetchRequestDecision _ _ _ _ _ PeerFetchStatusShutdown _ - = Left FetchDeclinePeerShutdown - -fetchRequestDecision _ _ _ _ _ PeerFetchStatusStarting _ - = Left FetchDeclinePeerStarting - -fetchRequestDecision _ _ _ _ _ PeerFetchStatusAberrant _ - = Left FetchDeclinePeerSlow - -fetchRequestDecision FetchDecisionPolicy { - maxConcurrencyBulkSync, - maxConcurrencyDeadline, - maxInFlightReqsPerPeer, - blockFetchSize - } - fetchMode - nConcurrentFetchPeers - PeerFetchInFlightLimits { - inFlightBytesLowWatermark, - inFlightBytesHighWatermark - } - PeerFetchInFlight { - peerFetchReqsInFlight, - peerFetchBytesInFlight - } - peerFetchStatus - (Right fetchFragments) - - | peerFetchReqsInFlight >= maxInFlightReqsPerPeer - = Left $ FetchDeclineReqsInFlightLimit - maxInFlightReqsPerPeer - - | peerFetchBytesInFlight >= inFlightBytesHighWatermark - = Left $ FetchDeclineBytesInFlightLimit - peerFetchBytesInFlight - inFlightBytesLowWatermark - inFlightBytesHighWatermark - - -- This covers the case when we could still fit in more reqs or bytes, but - -- we want to let it drop below a low water mark before sending more so we - -- get a bit more batching behaviour, rather than lots of 1-block reqs. - | peerFetchStatus == PeerFetchStatusBusy - = Left $ FetchDeclinePeerBusy - peerFetchBytesInFlight - inFlightBytesLowWatermark - inFlightBytesHighWatermark - - -- Refuse any blockrequest if we're above the concurrency limit. - | let maxConcurrentFetchPeers = case fetchMode of - FetchModeBulkSync -> maxConcurrencyBulkSync - FetchModeDeadline -> maxConcurrencyDeadline - , nConcurrentFetchPeers > maxConcurrentFetchPeers - = Left $ FetchDeclineConcurrencyLimit - fetchMode maxConcurrentFetchPeers - - -- If we're at the concurrency limit refuse any additional peers. - | peerFetchReqsInFlight == 0 - , let maxConcurrentFetchPeers = case fetchMode of - FetchModeBulkSync -> maxConcurrencyBulkSync - FetchModeDeadline -> maxConcurrencyDeadline - , nConcurrentFetchPeers == maxConcurrentFetchPeers - = Left $ FetchDeclineConcurrencyLimit - fetchMode maxConcurrentFetchPeers - - -- We've checked our request limit and our byte limit. We are then - -- guaranteed to get at least one non-empty request range. - | otherwise - = assert (peerFetchReqsInFlight < maxInFlightReqsPerPeer) $ - assert (not (null fetchFragments)) $ - - Right $ selectBlocksUpToLimits - blockFetchSize - peerFetchReqsInFlight - maxInFlightReqsPerPeer - peerFetchBytesInFlight - inFlightBytesHighWatermark - fetchFragments - - --- | --- --- Precondition: The result will be non-empty if --- --- Property: result is non-empty if preconditions satisfied --- -selectBlocksUpToLimits - :: forall header. HasHeader header - => (header -> SizeInBytes) -- ^ Block body size - -> Word -- ^ Current number of requests in flight - -> Word -- ^ Maximum number of requests in flight allowed - -> SizeInBytes -- ^ Current number of bytes in flight - -> SizeInBytes -- ^ Maximum number of bytes in flight allowed - -> [AnchoredFragment header] - -> FetchRequest header -selectBlocksUpToLimits blockFetchSize nreqs0 maxreqs nbytes0 maxbytes fragments = - assert (nreqs0 < maxreqs && nbytes0 < maxbytes && not (null fragments)) $ - -- The case that we are already over our limits has to be checked earlier, - -- outside of this function. From here on however we check for limits. - - let fragments' = goFrags nreqs0 nbytes0 fragments in - assert (all (not . AF.null) fragments') $ - FetchRequest fragments' - where - goFrags :: Word - -> SizeInBytes - -> [AnchoredFragment header] -> [AnchoredFragment header] - goFrags _ _ [] = [] - goFrags nreqs nbytes (c:cs) - | nreqs+1 > maxreqs = [] - | otherwise = goFrag (nreqs+1) nbytes (AF.Empty (AF.anchor c)) c cs - -- Each time we have to pick from a new discontiguous chain fragment then - -- that will become a new request, which contributes to our in-flight - -- request count. We never break the maxreqs limit. +fetchDecisions + fetchDecisionPolicy + FetchModeDeadline + currentChain + fetchedBlocks + fetchedMaxSlotNo + = + fetchDecisionsDeadline + fetchDecisionPolicy + currentChain + fetchedBlocks + fetchedMaxSlotNo - goFrag :: Word - -> SizeInBytes - -> AnchoredFragment header - -> AnchoredFragment header - -> [AnchoredFragment header] -> [AnchoredFragment header] - goFrag nreqs nbytes c' (Empty _) cs = c' : goFrags nreqs nbytes cs - goFrag nreqs nbytes c' (b :< c) cs - | nbytes' >= maxbytes = [c' :> b] - | otherwise = goFrag nreqs nbytes' (c' :> b) c cs - where - nbytes' = nbytes + blockFetchSize b - -- Note that we always pick the one last block that crosses the maxbytes - -- limit. This cover the case where we otherwise wouldn't even be able to - -- request a single block, as it's too large. +fetchDecisions + fetchDecisionPolicy + FetchModeBulkSync + currentChain + fetchedBlocks + fetchedMaxSlotNo + = + fetchDecisionsBulkSync + fetchDecisionPolicy + currentChain + fetchedBlocks + fetchedMaxSlotNo diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs new file mode 100644 index 00000000000..9105a52352b --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -0,0 +1,30 @@ +-- | This module contains the part of the block fetch decisions process that is +-- specific to the bulk sync mode. +module Ouroboros.Network.BlockFetch.Decision.BulkSync ( + fetchDecisionsBulkSync +) where + +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import Ouroboros.Network.Block +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..)) + +import Ouroboros.Network.BlockFetch.Decision.Common +-- REVIEW: We should not import anything from 'Decision.Deadline'; if the need +-- arises, we should move the interesting piece of code to 'Decision.Common'. +-- This is to be done on demand. + +fetchDecisionsBulkSync :: + FetchDecisionPolicy header + -> AnchoredFragment header + -> (Point block -> Bool) + -> MaxSlotNo + -> [(AnchoredFragment header, PeerInfo header peer extra)] + -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] + +fetchDecisionsBulkSync + _fetchDecisionPolicy + _currentChain + _fetchedBlocks + _fetchedMaxSlotNo + = + undefined diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs new file mode 100644 index 00000000000..3d6275b99c4 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE RankNTypes #-} + +-- | This module contains the part of the block fetch decisions process that is +-- common to both the bulk sync and deadline modes. +module Ouroboros.Network.BlockFetch.Decision.Common ( + FetchDecisionPolicy (..) + , PeerInfo + , FetchDecision + , FetchDecline (..) +) where + +import GHC.Stack (HasCallStack) +import Control.Monad.Class.MonadTime.SI (DiffTime) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import Ouroboros.Network.SizeInBytes ( SizeInBytes ) +import Ouroboros.Network.BlockFetch.ClientState (PeerFetchInFlight (..), PeerFetchStatus (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) +import Ouroboros.Network.DeltaQ ( PeerGSV ) + +data FetchDecisionPolicy header = FetchDecisionPolicy { + maxInFlightReqsPerPeer :: Word, -- A protocol constant. + + maxConcurrencyBulkSync :: Word, + maxConcurrencyDeadline :: Word, + decisionLoopInterval :: DiffTime, + peerSalt :: Int, + + plausibleCandidateChain :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header -> Bool, + + compareCandidateChains :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header + -> Ordering, + + blockFetchSize :: header -> SizeInBytes + } + +type PeerInfo header peer extra = + ( PeerFetchStatus header, + PeerFetchInFlight header, + PeerGSV, + peer, + extra + ) + +-- | Throughout the decision making process we accumulate reasons to decline +-- to fetch any blocks. This type is used to wrap intermediate and final +-- results. +-- +type FetchDecision result = Either FetchDecline result + +-- | All the various reasons we can decide not to fetch blocks from a peer. +-- +-- It is worth highlighting which of these reasons result from competition +-- among upstream peers. +-- +-- * 'FetchDeclineInFlightOtherPeer': decline this peer because all the +-- unfetched blocks of its candidate chain have already been requested from +-- other peers. This reason reflects the least-consequential competition +-- among peers: the competition that determines merely which upstream peer to +-- burden with the request (eg the one with the best +-- 'Ouroboros.Network.BlockFetch.DeltaQ.DeltaQ' metrics). The consequences +-- are relatively minor because the unfetched blocks on this peer's candidate +-- chain will be requested regardless; it's merely a question of "From who?". +-- (One exception: if an adversarial peer wins this competition such that the +-- blocks are only requested from them, then it may be possible that this +-- decision determines whether the blocks are ever /received/. But that +-- depends on details of timeouts, a longer competing chain being soon +-- received within those timeouts, and so on.) +-- +-- * 'FetchDeclineChainNotPlausible': decline this peer because the node has +-- already fetched, validated, and selected a chain better than its candidate +-- chain from other peers (or from the node's own block forge). Because the +-- node's current selection is influenced by what blocks other peers have +-- recently served (or it recently minted), this reason reflects that peers +-- /indirectly/ compete by serving as long of a chain as possible and as +-- promptly as possible. When the tips of the peers' selections are all +-- within their respective forecast horizons (see +-- 'Ouroboros.Consensus.Ledger.SupportsProtocol.ledgerViewForecastAt'), then +-- the length of their candidate chains will typically be the length of their +-- selections, since the ChainSync is free to race ahead (in contrast, the +-- BlockFetch pipeline depth is bounded such that it will, for a syncing +-- node, not be able to request all blocks between the selection and the end +-- of the forecast window). But if one or more of their tips is beyond the +-- horizon, then the relative length of the candidate chains is more +-- complicated, influenced by both the relative density of the chains' +-- suffixes and the relative age of the chains' intersection with the node's +-- selection (since each peer's forecast horizon is a fixed number of slots +-- after the candidate's successor of that intersection). +-- +-- * 'FetchDeclineConcurrencyLimit': decline this peer while the node has +-- already fully allocated the artificially scarce 'maxConcurrentFetchPeers' +-- resource amongst its other peers. This reason reflects the +-- least-fundamental competition: it's the only way a node would decline a +-- candidate chain C that it would immediately switch to if C had somehow +-- already been fetched (and any better current candidates hadn't). It is +-- possible that this peer's candidate fragment is better than the candidate +-- fragments of other peers, but that should only happen ephemerally (eg for +-- a brief while immediately after first connecting to this peer). +-- +-- * 'FetchDeclineChainIntersectionTooDeep': decline this peer because the node's +-- selection has more than @K@ blocks that are not on this peer's candidate +-- chain. Typically, this reason occurs after the node has been declined---ie +-- lost the above competitions---for a long enough duration. This decision +-- only arises if the BlockFetch decision logic wins a harmless race against +-- the ChainSync client once the node's selection gets longer, since +-- 'Ouroboros.Consensus.MiniProtocol.ChainSync.Client.ForkTooDeep' +-- disconnects from such a peer. +-- +data FetchDecline = + -- | This peer's candidate chain is not longer than our chain. For more + -- details see + -- 'Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface.mkBlockFetchConsensusInterface' + -- which implements 'plausibleCandidateChain'. + -- + FetchDeclineChainNotPlausible + + -- | Switching to this peer's candidate chain would require rolling back + -- more than @K@ blocks. + -- + | FetchDeclineChainIntersectionTooDeep + + -- | Every block on this peer's candidate chain has already been fetched. + -- + | FetchDeclineAlreadyFetched + + -- | This peer's candidate chain has already been requested from this + -- peer. + -- + | FetchDeclineInFlightThisPeer + + -- | Some blocks on this peer's candidate chain have not yet been fetched, + -- but all of those have already been requested from other peers. + -- + | FetchDeclineInFlightOtherPeer + + -- | This peer's BlockFetch client is shutting down, see + -- 'PeerFetchStatusShutdown'. + -- + | FetchDeclinePeerShutdown + + -- | Blockfetch is starting up and waiting on corresponding Chainsync. + | FetchDeclinePeerStarting + + + -- The reasons above this comment are fundamental and/or obvious. On the + -- other hand, the reasons below are heuristic. + + + -- | This peer is in a potentially-temporary state in which it has not + -- responded to us within a certain expected time limit, see + -- 'PeerFetchStatusAberrant'. + -- + | FetchDeclinePeerSlow + + -- | This peer is not under the 'maxInFlightReqsPerPeer' limit. + -- + -- The argument is the 'maxInFlightReqsPerPeer' constant. + -- + | FetchDeclineReqsInFlightLimit !Word + + -- | This peer is not under the 'inFlightBytesHighWatermark' bytes limit. + -- + -- The arguments are: + -- + -- * number of bytes currently in flight for that peer + -- * the configured 'inFlightBytesLowWatermark' constant + -- * the configured 'inFlightBytesHighWatermark' constant + -- + | FetchDeclineBytesInFlightLimit !SizeInBytes !SizeInBytes !SizeInBytes + + -- | This peer is not under the 'inFlightBytesLowWatermark'. + -- + -- The arguments are: + -- + -- * number of bytes currently in flight for that peer + -- * the configured 'inFlightBytesLowWatermark' constant + -- * the configured 'inFlightBytesHighWatermark' constant + -- + | FetchDeclinePeerBusy !SizeInBytes !SizeInBytes !SizeInBytes + + -- | The node is not under the 'maxConcurrentFetchPeers' limit. + -- + -- The arguments are: + -- + -- * the current 'FetchMode' + -- * the corresponding configured limit constant, either + -- 'maxConcurrencyBulkSync' or 'maxConcurrencyDeadline' + -- + | FetchDeclineConcurrencyLimit !FetchMode !Word + deriving (Eq, Show) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs new file mode 100644 index 00000000000..12a8fbae920 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -0,0 +1,969 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module contains the part of the block fetch decisions process that is +-- specific to the deadline mode. +module Ouroboros.Network.BlockFetch.Decision.Deadline + ( -- * Deciding what to fetch + fetchDecisionsDeadline + -- ** Components of the decision-making process + , filterPlausibleCandidates + , selectForkSuffixes + , filterNotAlreadyFetched + , filterNotAlreadyInFlightWithPeer + , prioritisePeerChains + , filterNotAlreadyInFlightWithOtherPeers + , fetchRequestDecisions + ) where + +import Data.Set qualified as Set + +import Data.Function (on) +import Data.Hashable +import Data.List (foldl', groupBy, sortBy, transpose) +import Data.Maybe (mapMaybe) +import Data.Set (Set) + +import Control.Exception (assert) +import Control.Monad (guard) + +import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq (..)) +import Ouroboros.Network.AnchoredFragment qualified as AF +import Ouroboros.Network.Block +import Ouroboros.Network.Point (withOriginToMaybe) + +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), + PeerFetchInFlight (..), PeerFetchStatus (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) +import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), + PeerGSV (..), SizeInBytes, calculatePeerFetchInFlightLimits, + comparePeerGSV, comparePeerGSV', estimateExpectedResponseDuration, + estimateResponseDeadlineProbability) + +import Ouroboros.Network.BlockFetch.Decision.Common + +-- | The \"oh noes?!\" operator. +-- +-- In the case of an error, the operator provides a specific error value. +-- +(?!) :: Maybe a -> e -> Either e a +Just x ?! _ = Right x +Nothing ?! e = Left e + +-- | The combination of a 'ChainSuffix' and a list of discontiguous +-- 'AnchoredFragment's: +-- +-- * When comparing two 'CandidateFragments' as candidate chains, we use the +-- 'ChainSuffix'. +-- +-- * To track which blocks of that candidate still have to be downloaded, we +-- use a list of discontiguous 'AnchoredFragment's. +-- +type CandidateFragments header = (ChainSuffix header, [AnchoredFragment header]) + + +fetchDecisionsDeadline + :: (Ord peer, + Hashable peer, + HasHeader header, + HeaderHash header ~ HeaderHash block) + => FetchDecisionPolicy header + -> AnchoredFragment header + -> (Point block -> Bool) + -> MaxSlotNo + -> [(AnchoredFragment header, PeerInfo header peer extra)] + -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] + +fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { + plausibleCandidateChain, + compareCandidateChains, + blockFetchSize, + peerSalt + } + currentChain + fetchedBlocks + fetchedMaxSlotNo = + + -- Finally, make a decision for each (chain, peer) pair. + fetchRequestDecisions + fetchDecisionPolicy + FetchModeDeadline + . map swizzleSIG + + -- Filter to keep blocks that are not already in-flight with other peers. + . filterNotAlreadyInFlightWithOtherPeers + FetchModeDeadline + . map swizzleSI + + -- Reorder chains based on consensus policy and network timing data. + . prioritisePeerChains + FetchModeDeadline + peerSalt + compareCandidateChains + blockFetchSize + . map swizzleIG + + -- Filter to keep blocks that are not already in-flight for this peer. + . filterNotAlreadyInFlightWithPeer + . map swizzleI + + -- Filter to keep blocks that have not already been downloaded. + . filterNotAlreadyFetched + fetchedBlocks + fetchedMaxSlotNo + + -- Select the suffix up to the intersection with the current chain. + . selectForkSuffixes + currentChain + + -- First, filter to keep chains the consensus layer tells us are plausible. + . filterPlausibleCandidates + plausibleCandidateChain + currentChain + where + -- Data swizzling functions to get the right info into each stage. + swizzleI (c, p@(_, inflight,_,_, _)) = (c, inflight, p) + swizzleIG (c, p@(_, inflight,gsvs,peer,_)) = (c, inflight, gsvs, peer, p) + swizzleSI (c, p@(status,inflight,_,_, _)) = (c, status, inflight, p) + swizzleSIG (c, p@(status,inflight,gsvs,peer,_)) = (c, status, inflight, gsvs, peer, p) + +{- +We have the node's /current/ or /adopted/ chain. This is the node's chain in +the sense specified by the Ouroboros algorithm. It is a fully verified chain +with block bodies and a ledger state. + + ┆ ┆ + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ │ + ───┴───┴─── current chain length (block number) + +With chain selection we are interested in /candidate/ chains. We have these +candidate chains in the form of chains of verified headers, but without bodies. + +The consensus layer gives us the current set of candidate chains from our peers +and we have the task of selecting which block bodies to download, and then +passing those block bodes back to the consensus layer. The consensus layer will +try to validate them and decide if it wants to update its current chain. + + ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ └───┘ + │ │ │ │ │ │ │ │ + ───┴───┴─────┼───┼─────┼───┼─────┼───┼───────────── current chain length + │ │ │ │ │ │ + current ├───┤ ├───┤ └───┘ + (blocks) │ │ │ │ + └───┘ └───┘ + A B C D + candidates + (headers) + +In this example we have four candidate chains, with all but chain D strictly +longer than our current chain. + +In general there are many candidate chains. We make a distinction between a +candidate chain and the peer from which it is available. It is often the +case that the same chain is available from multiple peers. We will try to be +clear about when we are referring to chains or the combination of a chain and +the peer from which it is available. + +For the sake of the example let us assume we have the four chains above +available from the following peers. + +peer 1 2 3 4 5 6 7 + ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ └───┘ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ │ │ + ──┼───┼─────┼───┼─────┼───┼─────┼───┼───────────────┼───┼─────┼───┼── + │ │ │ │ │ │ │ │ │ │ │ │ + └───┘ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + └───┘ └───┘ └───┘ └───┘ └───┘ +chain C A B A D B A + +This is the form in which we are informed about candidate chains from the +consensus layer, the combination of a chain and the peer it is from. This +makes sense, since these things change independently. + +We will process the chains in this form, keeping the peer/chain combination all +the way through. Although there could in principle be some opportunistic saving +by sharing when multiple peers provide the same chain, taking advantage of this +adds complexity and does nothing to improve our worst case costs. + +We are only interested in candidate chains that are strictly longer than our +current chain. So our first task is to filter down to this set. +-} + + +-- | Keep only those candidate chains that are preferred over the current +-- chain. Typically, this means that their length is longer than the length of +-- the current chain. +-- +filterPlausibleCandidates + :: (AnchoredFragment block -> AnchoredFragment header -> Bool) + -> AnchoredFragment block -- ^ The current chain + -> [(AnchoredFragment header, peerinfo)] + -> [(FetchDecision (AnchoredFragment header), peerinfo)] +filterPlausibleCandidates plausibleCandidateChain currentChain chains = + [ (chain', peer) + | (chain, peer) <- chains + , let chain' = do + guard (plausibleCandidateChain currentChain chain) + ?! FetchDeclineChainNotPlausible + return chain + ] + + +{- +In the example, this leaves us with only the candidate chains: A, B and C, but +still paired up with the various peers. + + +peer 1 2 3 4 6 7 + ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ │ │ + ──┼───┼─────┼───┼─────┼───┼─────┼───┼───────────────┼───┼─────┼───┼── + │ │ │ │ │ │ │ │ │ │ │ │ + └───┘ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + └───┘ └───┘ └───┘ └───┘ └───┘ +chain C A B A B A +-} + + +{- +Of course we would at most need to download the blocks in a candidate chain +that are not already in the current chain. So we must find those intersections. + +Before we do that, lets define how we represent a suffix of a chain. We do this +very simply as a chain fragment: exactly those blocks contained in the suffix. +A chain fragment is of course not a chain, but has many similar invariants. + +We will later also need to represent chain ranges when we send block fetch +requests. We do this using a pair of points: the first and last blocks in the +range. While we can represent an empty chain fragment, we cannot represent an +empty fetch range, but this is ok since we never request empty ranges. + + Chain fragment + ┌───┐ + │ ◉ │ Start of range, inclusive + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ ◉ │ End of range, inclusive. + └───┘ +-} + +-- | A chain suffix, obtained by intersecting a candidate chain with the +-- current chain. +-- +-- The anchor point of a 'ChainSuffix' will be a point within the bounds of +-- the current chain ('AF.withinFragmentBounds'), indicating that it forks off +-- in the last @K@ blocks. +-- +-- A 'ChainSuffix' must be non-empty, as an empty suffix, i.e. the candidate +-- chain is equal to the current chain, would not be a plausible candidate. +newtype ChainSuffix header = + ChainSuffix { getChainSuffix :: AnchoredFragment header } + +{- +We define the /chain suffix/ as the suffix of the candidate chain up until (but +not including) where it intersects the current chain. + + + current peer 1 peer 2 + + ┆ ┆ + ├───┤ + │ ◀┿━━━━━━━━━━━━━━━━━┓ + ├───┤ ┌─╂─┐ + │ │ │ ◉ │ + ├───┤ ├───┤ + │ │ │ │ + ├───┤ ├───┤ + │ ◀┿━━━━━━━┓ │ │ + ───┴───┴─────┬─╂─┬─────┼───┼─── + │ ◉ │ │ │ + └───┘ ├───┤ + │ ◉ │ + └───┘ + C A + +In this example we found that C was a strict extension of the current chain +and chain A was a short fork. + +Note that it's possible that we don't find any intersection within the last K +blocks. This means the candidate forks by more than K and so we are not +interested in this candidate at all. +-} + +-- | Find the chain suffix for a candidate chain, with respect to the +-- current chain. +-- +chainForkSuffix + :: (HasHeader header, HasHeader block, + HeaderHash header ~ HeaderHash block) + => AnchoredFragment block -- ^ Current chain. + -> AnchoredFragment header -- ^ Candidate chain + -> Maybe (ChainSuffix header) +chainForkSuffix current candidate = + case AF.intersect current candidate of + Nothing -> Nothing + Just (_, _, _, candidateSuffix) -> + -- If the suffix is empty, it means the candidate chain was equal to + -- the current chain and didn't fork off. Such a candidate chain is + -- not a plausible candidate, so it must have been filtered out. + assert (not (AF.null candidateSuffix)) $ + Just (ChainSuffix candidateSuffix) + +selectForkSuffixes + :: (HasHeader header, HasHeader block, + HeaderHash header ~ HeaderHash block) + => AnchoredFragment block + -> [(FetchDecision (AnchoredFragment header), peerinfo)] + -> [(FetchDecision (ChainSuffix header), peerinfo)] +selectForkSuffixes current chains = + [ (mchain', peer) + | (mchain, peer) <- chains + , let mchain' = do + chain <- mchain + chainForkSuffix current chain ?! FetchDeclineChainIntersectionTooDeep + ] + +{- +We define the /fetch range/ as the suffix of the fork range that has not yet +had its blocks downloaded and block content checked against the headers. + + ┆ ┆ + ├───┤ + │ │ + ├───┤ ┌───┐ + │ │ already │ │ + ├───┤ fetched ├───┤ + │ │ blocks │ │ + ├───┤ ├───┤ + │ │ │░◉░│ ◄ fetch range + ───┴───┴─────┬───┬─────┼───┼─── + │░◉░│ ◄ │░░░│ + └───┘ ├───┤ + │░◉░│ ◄ + └───┘ + +In earlier versions of this scheme we maintained and relied on the invariant +that the ranges of fetched blocks are backwards closed. This meant we never had +discontinuous ranges of fetched or not-yet-fetched blocks. This invariant does +simplify things somewhat by keeping the ranges continuous however it precludes +fetching ranges of blocks from different peers in parallel. + +We do not maintain any such invariant and so we have to deal with there being +gaps in the ranges we have already fetched or are yet to fetch. To keep the +tracking simple we do not track the ranges themselves, rather we track the set +of individual blocks without their relationship to each other. + +-} + +-- | Find the fragments of the chain suffix that we still need to fetch, these +-- are the fragments covering blocks that have not yet been fetched and are +-- not currently in the process of being fetched from this peer. +-- +-- Typically this is a single fragment forming a suffix of the chain, but in +-- the general case we can get a bunch of discontiguous chain fragments. +-- +filterNotAlreadyFetched + :: (HasHeader header, HeaderHash header ~ HeaderHash block) + => (Point block -> Bool) + -> MaxSlotNo + -> [(FetchDecision (ChainSuffix header), peerinfo)] + -> [(FetchDecision (CandidateFragments header), peerinfo)] +filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo chains = + [ (mcandidates, peer) + | (mcandidate, peer) <- chains + , let mcandidates = do + candidate <- mcandidate + let fragments = filterWithMaxSlotNo + notAlreadyFetched + fetchedMaxSlotNo + (getChainSuffix candidate) + guard (not (null fragments)) ?! FetchDeclineAlreadyFetched + return (candidate, fragments) + ] + where + notAlreadyFetched = not . alreadyDownloaded . castPoint . blockPoint + + +filterNotAlreadyInFlightWithPeer + :: HasHeader header + => [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, + peerinfo)] + -> [(FetchDecision (CandidateFragments header), peerinfo)] +filterNotAlreadyInFlightWithPeer chains = + [ (mcandidatefragments', peer) + | (mcandidatefragments, inflight, peer) <- chains + , let mcandidatefragments' = do + (candidate, chainfragments) <- mcandidatefragments + let fragments = concatMap (filterWithMaxSlotNo + (notAlreadyInFlight inflight) + (peerFetchMaxSlotNo inflight)) + chainfragments + guard (not (null fragments)) ?! FetchDeclineInFlightThisPeer + return (candidate, fragments) + ] + where + notAlreadyInFlight inflight b = + blockPoint b `Set.notMember` peerFetchBlocksInFlight inflight + + +-- | A penultimate step of filtering, but this time across peers, rather than +-- individually for each peer. If we're following the parallel fetch +-- mode then we filter out blocks that are already in-flight with other +-- peers. +-- +-- Note that this does /not/ cover blocks that are proposed to be fetched in +-- this round of decisions. That step is covered in 'fetchRequestDecisions'. +-- +filterNotAlreadyInFlightWithOtherPeers + :: HasHeader header + => FetchMode + -> [( FetchDecision [AnchoredFragment header] + , PeerFetchStatus header + , PeerFetchInFlight header + , peerinfo )] + -> [(FetchDecision [AnchoredFragment header], peerinfo)] + +filterNotAlreadyInFlightWithOtherPeers FetchModeDeadline chains = + [ (mchainfragments, peer) + | (mchainfragments, _, _, peer) <- chains ] + +filterNotAlreadyInFlightWithOtherPeers FetchModeBulkSync chains = + [ (mcandidatefragments', peer) + | (mcandidatefragments, _, _, peer) <- chains + , let mcandidatefragments' = do + chainfragments <- mcandidatefragments + let fragments = concatMap (filterWithMaxSlotNo + notAlreadyInFlight + maxSlotNoInFlightWithOtherPeers) + chainfragments + guard (not (null fragments)) ?! FetchDeclineInFlightOtherPeer + return fragments + ] + where + notAlreadyInFlight b = + blockPoint b `Set.notMember` blocksInFlightWithOtherPeers + + -- All the blocks that are already in-flight with all peers + blocksInFlightWithOtherPeers = + Set.unions + [ case status of + PeerFetchStatusShutdown -> Set.empty + PeerFetchStatusStarting -> Set.empty + PeerFetchStatusAberrant -> Set.empty + _other -> peerFetchBlocksInFlight inflight + | (_, status, inflight, _) <- chains ] + + -- The highest slot number that is or has been in flight for any peer. + maxSlotNoInFlightWithOtherPeers = foldl' max NoMaxSlotNo + [ peerFetchMaxSlotNo inflight | (_, _, inflight, _) <- chains ] + +-- | Filter a fragment. This is an optimised variant that will behave the same +-- as 'AnchoredFragment.filter' if the following precondition is satisfied: +-- +-- PRECONDITION: for all @hdr@ in the chain fragment: if @blockSlot hdr > +-- maxSlotNo@ then the predicate should not hold for any header after @hdr@ in +-- the chain fragment. +-- +-- For example, when filtering out already downloaded blocks from the +-- fragment, it does not make sense to keep filtering after having encountered +-- the highest slot number the ChainDB has seen so far: blocks with a greater +-- slot number cannot have been downloaded yet. When the candidate fragments +-- get far ahead of the current chain, e.g., @2k@ headers, this optimisation +-- avoids the linear cost of filtering these headers when we know in advance +-- they will all remain in the final fragment. In case the given slot number +-- is 'NoSlotNo', no filtering takes place, as there should be no matches +-- because we haven't downloaded any blocks yet. +-- +-- For example, when filtering out blocks already in-flight for the given +-- peer, the given @maxSlotNo@ can correspond to the block with the highest +-- slot number that so far has been in-flight for the given peer. When no +-- blocks have been in-flight yet, @maxSlotNo@ can be 'NoSlotNo', in which +-- case no filtering needs to take place, which makes sense, as there are no +-- blocks to filter out. Note that this is conservative: if a block is for +-- some reason multiple times in-flight (maybe it has to be redownloaded) and +-- the block's slot number matches the @maxSlotNo@, it will now be filtered +-- (while the filtering might previously have stopped before encountering the +-- block in question). This is fine, as the filter will now include the block, +-- because according to the filtering predicate, the block is not in-flight. +filterWithMaxSlotNo + :: forall header. HasHeader header + => (header -> Bool) + -> MaxSlotNo -- ^ @maxSlotNo@ + -> AnchoredFragment header + -> [AnchoredFragment header] +filterWithMaxSlotNo p maxSlotNo = + AF.filterWithStop p ((> maxSlotNo) . MaxSlotNo . blockSlot) + +prioritisePeerChains + :: forall extra header peer. + ( HasHeader header + , Hashable peer + , Ord peer + ) + => FetchMode + -> Int + -> (AnchoredFragment header -> AnchoredFragment header -> Ordering) + -> (header -> SizeInBytes) + -> [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, + PeerGSV, + peer, + extra )] + -> [(FetchDecision [AnchoredFragment header], extra)] +prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSize = + map (\(decision, peer) -> + (fmap (\(_,_,fragment) -> fragment) decision, peer)) + . concatMap ( concat + . transpose + . groupBy (equatingFst + (equatingRight + ((==) `on` chainHeadPoint))) + . sortBy (comparingFst + (comparingRight + (compare `on` chainHeadPoint))) + ) + . groupBy (equatingFst + (equatingRight + (equatingPair + -- compare on probability band first, then preferred chain + (==) + (equateCandidateChains `on` getChainSuffix) + `on` + (\(band, chain, _fragments) -> (band, chain))))) + . sortBy (descendingOrder + (comparingFst + (comparingRight + (comparingPair + -- compare on probability band first, then preferred chain + compare + (compareCandidateChains `on` getChainSuffix) + `on` + (\(band, chain, _fragments) -> (band, chain)))))) + . map annotateProbabilityBand + . sortBy (\(_,_,a,ap,_) (_,_,b,bp,_) -> + comparePeerGSV' salt (a,ap) (b,bp)) + where + annotateProbabilityBand (Left decline, _, _, _, peer) = (Left decline, peer) + annotateProbabilityBand (Right (chain,fragments), inflight, gsvs, _, peer) = + (Right (band, chain, fragments), peer) + where + band = probabilityBand $ + estimateResponseDeadlineProbability + gsvs + (peerFetchBytesInFlight inflight) + (totalFetchSize blockFetchSize fragments) + deadline + + deadline = 2 -- seconds -- TODO: get this from external info + + equateCandidateChains chain1 chain2 + | EQ <- compareCandidateChains chain1 chain2 = True + | otherwise = False + + chainHeadPoint (_,ChainSuffix c,_) = AF.headPoint c + +prioritisePeerChains FetchModeBulkSync salt compareCandidateChains blockFetchSize = + map (\(decision, peer) -> + (fmap (\(_, _, fragment) -> fragment) decision, peer)) + . sortBy (comparingFst + (comparingRight + (comparingPair + -- compare on preferred chain first, then duration + (compareCandidateChains `on` getChainSuffix) + compare + `on` + (\(duration, chain, _fragments) -> (chain, duration))))) + . map annotateDuration + . sortBy (\(_,_,a,ap,_) (_,_,b,bp,_) -> + comparePeerGSV' salt (a,ap) (b,bp)) + where + annotateDuration (Left decline, _, _, _, peer) = (Left decline, peer) + annotateDuration (Right (chain,fragments), inflight, gsvs, _, peer) = + (Right (duration, chain, fragments), peer) + where + -- TODO: consider if we should put this into bands rather than just + -- taking the full value. + duration = estimateExpectedResponseDuration + gsvs + (peerFetchBytesInFlight inflight) + (totalFetchSize blockFetchSize fragments) + +totalFetchSize :: (header -> SizeInBytes) + -> [AnchoredFragment header] + -> SizeInBytes +totalFetchSize blockFetchSize fragments = + sum [ blockFetchSize header + | fragment <- fragments + , header <- AF.toOldestFirst fragment ] + +type Comparing a = a -> a -> Ordering +type Equating a = a -> a -> Bool + +descendingOrder :: Comparing a -> Comparing a +descendingOrder cmp = flip cmp + +comparingPair :: Comparing a -> Comparing b -> Comparing (a, b) +comparingPair cmpA cmpB (a1, b1) (a2, b2) = cmpA a1 a2 <> cmpB b1 b2 + +equatingPair :: Equating a -> Equating b -> Equating (a, b) +equatingPair eqA eqB (a1, b1) (a2, b2) = eqA a1 a2 && eqB b1 b2 + +comparingEither :: Comparing a -> Comparing b -> Comparing (Either a b) +comparingEither _ _ (Left _) (Right _) = LT +comparingEither cmpA _ (Left x) (Left y) = cmpA x y +comparingEither _ cmpB (Right x) (Right y) = cmpB x y +comparingEither _ _ (Right _) (Left _) = GT + +equatingEither :: Equating a -> Equating b -> Equating (Either a b) +equatingEither _ _ (Left _) (Right _) = False +equatingEither eqA _ (Left x) (Left y) = eqA x y +equatingEither _ eqB (Right x) (Right y) = eqB x y +equatingEither _ _ (Right _) (Left _) = False + +comparingFst :: Comparing a -> Comparing (a, b) +comparingFst cmp = cmp `on` fst + +equatingFst :: Equating a -> Equating (a, b) +equatingFst eq = eq `on` fst + +comparingRight :: Comparing b -> Comparing (Either a b) +comparingRight = comparingEither mempty + +equatingRight :: Equating b -> Equating (Either a b) +equatingRight = equatingEither (\_ _ -> True) + +-- | Given the probability of the download completing within the deadline, +-- classify that into one of three broad bands: high, medium and low. +-- +-- The bands are +-- +-- * high: 98% -- 100% +-- * medium: 75% -- 98% +-- * low: 0% -- 75% +-- +probabilityBand :: Double -> ProbabilityBand +probabilityBand p + | p > 0.98 = ProbabilityHigh + | p > 0.75 = ProbabilityModerate + | otherwise = ProbabilityLow + -- TODO: for hysteresis, increase probability if we're already using this peer + +data ProbabilityBand = ProbabilityLow + | ProbabilityModerate + | ProbabilityHigh + deriving (Eq, Ord, Show) + + +{- +In the second phase we walk over the prioritised fetch suffixes for each peer +and make a decision about whether we should initiate any new fetch requests. + +This decision is based on a number of factors: + + * Is the fetch suffix empty? If so, there's nothing to do. + * Do we already have block fetch requests in flight with this peer? + * If so are we under the maximum number of in-flight blocks for this peer? + * Is this peer still performing within expectations or has it missed any soft + time outs? + * Has the peer missed any hard timeouts or otherwise been disconnected. + * Are we at our soft or hard limit of the number of peers we are prepared to + fetch blocks from concurrently? + +We look at each peer chain fetch suffix one by one. Of course decisions we +make earlier can affect decisions later, in particular the number of peers we +fetch from concurrently can increase if we fetch from a new peer, and we must +obviously take that into account when considering later peer chains. +-} + + +fetchRequestDecisions + :: forall extra header peer. + ( Hashable peer + , HasHeader header + , Ord peer + ) + => FetchDecisionPolicy header + -> FetchMode + -> [( FetchDecision [AnchoredFragment header] + , PeerFetchStatus header + , PeerFetchInFlight header + , PeerGSV + , peer + , extra)] + -> [(FetchDecision (FetchRequest header), extra)] +fetchRequestDecisions fetchDecisionPolicy fetchMode chains = + go nConcurrentFetchPeers0 Set.empty NoMaxSlotNo chains + where + go :: Word + -> Set (Point header) + -> MaxSlotNo + -> [(Either FetchDecline [AnchoredFragment header], + PeerFetchStatus header, PeerFetchInFlight header, PeerGSV, peer, extra)] + -> [(FetchDecision (FetchRequest header), extra)] + go !_ !_ !_ [] = [] + go !nConcurrentFetchPeers !blocksFetchedThisRound !maxSlotNoFetchedThisRound + ((mchainfragments, status, inflight, gsvs, peer, extra) : cps) = + + (decision, extra) + : go nConcurrentFetchPeers' blocksFetchedThisRound' + maxSlotNoFetchedThisRound' cps + where + decision = fetchRequestDecision + fetchDecisionPolicy + fetchMode + -- Permit the preferred peers to by pass any concurrency limits. + (if elem peer nPreferedPeers then 0 + else nConcurrentFetchPeers) + (calculatePeerFetchInFlightLimits gsvs) + inflight + status + mchainfragments' + + mchainfragments' = + case fetchMode of + FetchModeDeadline -> mchainfragments + FetchModeBulkSync -> do + chainfragments <- mchainfragments + let fragments = + concatMap (filterWithMaxSlotNo + notFetchedThisRound + maxSlotNoFetchedThisRound) + chainfragments + guard (not (null fragments)) ?! FetchDeclineInFlightOtherPeer + return fragments + where + notFetchedThisRound h = + blockPoint h `Set.notMember` blocksFetchedThisRound + + nConcurrentFetchPeers' + -- increment if it was idle, and now will not be + | peerFetchReqsInFlight inflight == 0 + , Right{} <- decision = nConcurrentFetchPeers + 1 + | otherwise = nConcurrentFetchPeers + + -- This is only for avoiding duplication between fetch requests in this + -- round of decisions. Avoiding duplication with blocks that are already + -- in flight is handled by filterNotAlreadyInFlightWithOtherPeers + (blocksFetchedThisRound', maxSlotNoFetchedThisRound') = + case decision of + Left _ -> + (blocksFetchedThisRound, maxSlotNoFetchedThisRound) + Right (FetchRequest fragments) -> + (blocksFetchedThisRound `Set.union` blocksFetchedThisDecision, + maxSlotNoFetchedThisRound `max` maxSlotNoFetchedThisDecision) + where + maxSlotNoFetchedThisDecision = + foldl' max NoMaxSlotNo $ map MaxSlotNo $ + mapMaybe (withOriginToMaybe . AF.headSlot) fragments + + blocksFetchedThisDecision = + Set.fromList + [ blockPoint header + | fragment <- fragments + , header <- AF.toOldestFirst fragment ] + + nConcurrentFetchPeers0 = fromIntegral $ Set.size nActivePeers + + -- Set of peers with outstanding bytes. + nActivePeers :: Set peer + nActivePeers = + Set.fromList + . map snd + . filter (\(inFlight, _) -> inFlight > 0) + . map (\(_, _, PeerFetchInFlight{peerFetchReqsInFlight}, _, p, _) -> + (peerFetchReqsInFlight, p)) + $ chains + + -- Order the peers based on current PeerGSV. The top performing peers will be + -- permitted to go active even if we're above the desired maxConcurrentFetchPeers + -- which will cause us to switch smoothly from a slower to faster peers. + -- When switching from slow to faster peers we will be over the configured limit, but + -- PeerGSV is expected to be updated rather infrequently so the set of preferred peers should + -- be stable during 10s of seconds. + nPreferedPeers :: [peer] + nPreferedPeers = + map snd + . take (fromIntegral maxConcurrentFetchPeers) + . sortBy (\a b -> comparePeerGSV nActivePeers (peerSalt fetchDecisionPolicy) a b) + . map (\(_, _, _, gsv, p, _) -> (gsv, p)) + $ chains + + maxConcurrentFetchPeers :: Word + maxConcurrentFetchPeers = + case fetchMode of + FetchModeBulkSync -> maxConcurrencyBulkSync fetchDecisionPolicy + FetchModeDeadline -> maxConcurrencyDeadline fetchDecisionPolicy + + +fetchRequestDecision + :: HasHeader header + => FetchDecisionPolicy header + -> FetchMode + -> Word + -> PeerFetchInFlightLimits + -> PeerFetchInFlight header + -> PeerFetchStatus header + -> FetchDecision [AnchoredFragment header] + -> FetchDecision (FetchRequest header) + +fetchRequestDecision _ _ _ _ _ _ (Left decline) + = Left decline + +fetchRequestDecision _ _ _ _ _ PeerFetchStatusShutdown _ + = Left FetchDeclinePeerShutdown + +fetchRequestDecision _ _ _ _ _ PeerFetchStatusStarting _ + = Left FetchDeclinePeerStarting + +fetchRequestDecision _ _ _ _ _ PeerFetchStatusAberrant _ + = Left FetchDeclinePeerSlow + +fetchRequestDecision FetchDecisionPolicy { + maxConcurrencyBulkSync, + maxConcurrencyDeadline, + maxInFlightReqsPerPeer, + blockFetchSize + } + fetchMode + nConcurrentFetchPeers + PeerFetchInFlightLimits { + inFlightBytesLowWatermark, + inFlightBytesHighWatermark + } + PeerFetchInFlight { + peerFetchReqsInFlight, + peerFetchBytesInFlight + } + peerFetchStatus + (Right fetchFragments) + + | peerFetchReqsInFlight >= maxInFlightReqsPerPeer + = Left $ FetchDeclineReqsInFlightLimit + maxInFlightReqsPerPeer + + | peerFetchBytesInFlight >= inFlightBytesHighWatermark + = Left $ FetchDeclineBytesInFlightLimit + peerFetchBytesInFlight + inFlightBytesLowWatermark + inFlightBytesHighWatermark + + -- This covers the case when we could still fit in more reqs or bytes, but + -- we want to let it drop below a low water mark before sending more so we + -- get a bit more batching behaviour, rather than lots of 1-block reqs. + | peerFetchStatus == PeerFetchStatusBusy + = Left $ FetchDeclinePeerBusy + peerFetchBytesInFlight + inFlightBytesLowWatermark + inFlightBytesHighWatermark + + -- Refuse any blockrequest if we're above the concurrency limit. + | let maxConcurrentFetchPeers = case fetchMode of + FetchModeBulkSync -> maxConcurrencyBulkSync + FetchModeDeadline -> maxConcurrencyDeadline + , nConcurrentFetchPeers > maxConcurrentFetchPeers + = Left $ FetchDeclineConcurrencyLimit + fetchMode maxConcurrentFetchPeers + + -- If we're at the concurrency limit refuse any additional peers. + | peerFetchReqsInFlight == 0 + , let maxConcurrentFetchPeers = case fetchMode of + FetchModeBulkSync -> maxConcurrencyBulkSync + FetchModeDeadline -> maxConcurrencyDeadline + , nConcurrentFetchPeers == maxConcurrentFetchPeers + = Left $ FetchDeclineConcurrencyLimit + fetchMode maxConcurrentFetchPeers + + -- We've checked our request limit and our byte limit. We are then + -- guaranteed to get at least one non-empty request range. + | otherwise + = assert (peerFetchReqsInFlight < maxInFlightReqsPerPeer) $ + assert (not (null fetchFragments)) $ + + Right $ selectBlocksUpToLimits + blockFetchSize + peerFetchReqsInFlight + maxInFlightReqsPerPeer + peerFetchBytesInFlight + inFlightBytesHighWatermark + fetchFragments + + +-- | +-- +-- Precondition: The result will be non-empty if +-- +-- Property: result is non-empty if preconditions satisfied +-- +selectBlocksUpToLimits + :: forall header. HasHeader header + => (header -> SizeInBytes) -- ^ Block body size + -> Word -- ^ Current number of requests in flight + -> Word -- ^ Maximum number of requests in flight allowed + -> SizeInBytes -- ^ Current number of bytes in flight + -> SizeInBytes -- ^ Maximum number of bytes in flight allowed + -> [AnchoredFragment header] + -> FetchRequest header +selectBlocksUpToLimits blockFetchSize nreqs0 maxreqs nbytes0 maxbytes fragments = + assert (nreqs0 < maxreqs && nbytes0 < maxbytes && not (null fragments)) $ + -- The case that we are already over our limits has to be checked earlier, + -- outside of this function. From here on however we check for limits. + + let fragments' = goFrags nreqs0 nbytes0 fragments in + assert (all (not . AF.null) fragments') $ + FetchRequest fragments' + where + goFrags :: Word + -> SizeInBytes + -> [AnchoredFragment header] -> [AnchoredFragment header] + goFrags _ _ [] = [] + goFrags nreqs nbytes (c:cs) + | nreqs+1 > maxreqs = [] + | otherwise = goFrag (nreqs+1) nbytes (AF.Empty (AF.anchor c)) c cs + -- Each time we have to pick from a new discontiguous chain fragment then + -- that will become a new request, which contributes to our in-flight + -- request count. We never break the maxreqs limit. + + goFrag :: Word + -> SizeInBytes + -> AnchoredFragment header + -> AnchoredFragment header + -> [AnchoredFragment header] -> [AnchoredFragment header] + goFrag nreqs nbytes c' (Empty _) cs = c' : goFrags nreqs nbytes cs + goFrag nreqs nbytes c' (b :< c) cs + | nbytes' >= maxbytes = [c' :> b] + | otherwise = goFrag nreqs nbytes' (c' :> b) c cs + where + nbytes' = nbytes + blockFetchSize b + -- Note that we always pick the one last block that crosses the maxbytes + -- limit. This cover the case where we otherwise wouldn't even be able to + -- request a single block, as it's too large. From c356465dc76fb83741824c48aefd05846fc848f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 5 Jun 2024 10:53:33 +0000 Subject: [PATCH 002/136] Start writing a simple BlockFetch decision logic --- .../Ouroboros/Network/BlockFetch/Decision.hs | 8 +- .../Network/BlockFetch/Decision/BulkSync.hs | 71 +++- .../Network/BlockFetch/Decision/Common.hs | 287 +++++++++++++++ .../Network/BlockFetch/Decision/Deadline.hs | 336 ------------------ 4 files changed, 358 insertions(+), 344 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index dffdfdb8398..2561969bec4 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -29,9 +29,11 @@ import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) -import Ouroboros.Network.BlockFetch.Decision.Common -import Ouroboros.Network.BlockFetch.Decision.Deadline -import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSync) +import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), + filterPlausibleCandidates, filterNotAlreadyFetched, filterNotAlreadyInFlightWithPeer) +import Ouroboros.Network.BlockFetch.Decision.Deadline (fetchDecisionsDeadline, selectForkSuffixes, + prioritisePeerChains, fetchRequestDecisions) +import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSync, filterNotAlreadyInFlightWithOtherPeers) fetchDecisions :: (Ord peer, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 9105a52352b..30f00776720 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -1,14 +1,20 @@ +{-# LANGUAGE NamedFieldPuns #-} + -- | This module contains the part of the block fetch decisions process that is -- specific to the bulk sync mode. module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync -) where +, filterNotAlreadyInFlightWithOtherPeers) where import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), + PeerFetchInFlight (..), PeerFetchStatus (..)) import Ouroboros.Network.BlockFetch.Decision.Common +import Control.Monad (guard) +import qualified Data.Set as Set +import Data.List (foldl', singleton) -- REVIEW: We should not import anything from 'Decision.Deadline'; if the need -- arises, we should move the interesting piece of code to 'Decision.Common'. -- This is to be done on demand. @@ -22,9 +28,64 @@ fetchDecisionsBulkSync :: -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisionsBulkSync - _fetchDecisionPolicy - _currentChain + _fetchDecisionPolicy@FetchDecisionPolicy { + plausibleCandidateChain + } + currentChain _fetchedBlocks _fetchedMaxSlotNo = - undefined + map (\(fd, peer) -> + (FetchRequest . singleton <$> fd, peer) + ) + + -- First, filter to keep chains the consensus layer tells us are plausible. + . filterPlausibleCandidates + plausibleCandidateChain + currentChain + +-- | A penultimate step of filtering, but this time across peers, rather than +-- individually for each peer. If we're following the parallel fetch +-- mode then we filter out blocks that are already in-flight with other +-- peers. +-- +-- Note that this does /not/ cover blocks that are proposed to be fetched in +-- this round of decisions. That step is covered in 'fetchRequestDecisions'. +-- +filterNotAlreadyInFlightWithOtherPeers + :: HasHeader header + => [( FetchDecision [AnchoredFragment header] + , PeerFetchStatus header + , PeerFetchInFlight header + , peerinfo )] + -> [(FetchDecision [AnchoredFragment header], peerinfo)] + +filterNotAlreadyInFlightWithOtherPeers chains = + [ (mcandidatefragments', peer) + | (mcandidatefragments, _, _, peer) <- chains + , let mcandidatefragments' = do + chainfragments <- mcandidatefragments + let fragments = concatMap (filterWithMaxSlotNo + notAlreadyInFlight + maxSlotNoInFlightWithOtherPeers) + chainfragments + guard (not (null fragments)) ?! FetchDeclineInFlightOtherPeer + return fragments + ] + where + notAlreadyInFlight b = + blockPoint b `Set.notMember` blocksInFlightWithOtherPeers + + -- All the blocks that are already in-flight with all peers + blocksInFlightWithOtherPeers = + Set.unions + [ case status of + PeerFetchStatusShutdown -> Set.empty + PeerFetchStatusStarting -> Set.empty + PeerFetchStatusAberrant -> Set.empty + _other -> peerFetchBlocksInFlight inflight + | (_, status, inflight, _) <- chains ] + + -- The highest slot number that is or has been in flight for any peer. + maxSlotNoInFlightWithOtherPeers = foldl' max NoMaxSlotNo + [ peerFetchMaxSlotNo inflight | (_, _, inflight, _) <- chains ] diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index 3d6275b99c4..d099238087e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -1,4 +1,6 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} -- | This module contains the part of the block fetch decisions process that is -- common to both the bulk sync and deadline modes. @@ -7,6 +9,13 @@ module Ouroboros.Network.BlockFetch.Decision.Common ( , PeerInfo , FetchDecision , FetchDecline (..) + , ChainSuffix (..) + , filterNotAlreadyFetched + , filterNotAlreadyInFlightWithPeer + , (?!) + , CandidateFragments + , filterWithMaxSlotNo + , filterPlausibleCandidates ) where import GHC.Stack (HasCallStack) @@ -16,6 +25,10 @@ import Ouroboros.Network.SizeInBytes ( SizeInBytes ) import Ouroboros.Network.BlockFetch.ClientState (PeerFetchInFlight (..), PeerFetchStatus (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) import Ouroboros.Network.DeltaQ ( PeerGSV ) +import Ouroboros.Network.Block (HasHeader, HeaderHash, Point, MaxSlotNo (..), castPoint, blockPoint, blockSlot) +import Control.Monad (guard) +import qualified Ouroboros.Network.AnchoredFragment as AF +import qualified Data.Set as Set data FetchDecisionPolicy header = FetchDecisionPolicy { maxInFlightReqsPerPeer :: Word, -- A protocol constant. @@ -191,3 +204,277 @@ data FetchDecline = -- | FetchDeclineConcurrencyLimit !FetchMode !Word deriving (Eq, Show) + +-- | The combination of a 'ChainSuffix' and a list of discontiguous +-- 'AnchoredFragment's: +-- +-- * When comparing two 'CandidateFragments' as candidate chains, we use the +-- 'ChainSuffix'. +-- +-- * To track which blocks of that candidate still have to be downloaded, we +-- use a list of discontiguous 'AnchoredFragment's. +-- +type CandidateFragments header = (ChainSuffix header, [AnchoredFragment header]) + +{- +Of course we would at most need to download the blocks in a candidate chain +that are not already in the current chain. So we must find those intersections. + +Before we do that, lets define how we represent a suffix of a chain. We do this +very simply as a chain fragment: exactly those blocks contained in the suffix. +A chain fragment is of course not a chain, but has many similar invariants. + +We will later also need to represent chain ranges when we send block fetch +requests. We do this using a pair of points: the first and last blocks in the +range. While we can represent an empty chain fragment, we cannot represent an +empty fetch range, but this is ok since we never request empty ranges. + + Chain fragment + ┌───┐ + │ ◉ │ Start of range, inclusive + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ ◉ │ End of range, inclusive. + └───┘ +-} + +-- | A chain suffix, obtained by intersecting a candidate chain with the +-- current chain. +-- +-- The anchor point of a 'ChainSuffix' will be a point within the bounds of +-- the current chain ('AF.withinFragmentBounds'), indicating that it forks off +-- in the last @K@ blocks. +-- +-- A 'ChainSuffix' must be non-empty, as an empty suffix, i.e. the candidate +-- chain is equal to the current chain, would not be a plausible candidate. +newtype ChainSuffix header = + ChainSuffix { getChainSuffix :: AnchoredFragment header } + +{- +We have the node's /current/ or /adopted/ chain. This is the node's chain in +the sense specified by the Ouroboros algorithm. It is a fully verified chain +with block bodies and a ledger state. + + ┆ ┆ + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ │ + ───┴───┴─── current chain length (block number) + +With chain selection we are interested in /candidate/ chains. We have these +candidate chains in the form of chains of verified headers, but without bodies. + +The consensus layer gives us the current set of candidate chains from our peers +and we have the task of selecting which block bodies to download, and then +passing those block bodes back to the consensus layer. The consensus layer will +try to validate them and decide if it wants to update its current chain. + + ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ └───┘ + │ │ │ │ │ │ │ │ + ───┴───┴─────┼───┼─────┼───┼─────┼───┼───────────── current chain length + │ │ │ │ │ │ + current ├───┤ ├───┤ └───┘ + (blocks) │ │ │ │ + └───┘ └───┘ + A B C D + candidates + (headers) + +In this example we have four candidate chains, with all but chain D strictly +longer than our current chain. + +In general there are many candidate chains. We make a distinction between a +candidate chain and the peer from which it is available. It is often the +case that the same chain is available from multiple peers. We will try to be +clear about when we are referring to chains or the combination of a chain and +the peer from which it is available. + +For the sake of the example let us assume we have the four chains above +available from the following peers. + +peer 1 2 3 4 5 6 7 + ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ └───┘ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ │ │ + ──┼───┼─────┼───┼─────┼───┼─────┼───┼───────────────┼───┼─────┼───┼── + │ │ │ │ │ │ │ │ │ │ │ │ + └───┘ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + └───┘ └───┘ └───┘ └───┘ └───┘ +chain C A B A D B A + +This is the form in which we are informed about candidate chains from the +consensus layer, the combination of a chain and the peer it is from. This +makes sense, since these things change independently. + +We will process the chains in this form, keeping the peer/chain combination all +the way through. Although there could in principle be some opportunistic saving +by sharing when multiple peers provide the same chain, taking advantage of this +adds complexity and does nothing to improve our worst case costs. + +We are only interested in candidate chains that are strictly longer than our +current chain. So our first task is to filter down to this set. +-} + +-- | Keep only those candidate chains that are preferred over the current +-- chain. Typically, this means that their length is longer than the length of +-- the current chain. +-- +filterPlausibleCandidates + :: (AnchoredFragment block -> AnchoredFragment header -> Bool) + -> AnchoredFragment block -- ^ The current chain + -> [(AnchoredFragment header, peerinfo)] + -> [(FetchDecision (AnchoredFragment header), peerinfo)] +filterPlausibleCandidates plausibleCandidateChain currentChain chains = + [ (chain', peer) + | (chain, peer) <- chains + , let chain' = do + guard (plausibleCandidateChain currentChain chain) + ?! FetchDeclineChainNotPlausible + return chain + ] + +{- +We define the /fetch range/ as the suffix of the fork range that has not yet +had its blocks downloaded and block content checked against the headers. + + ┆ ┆ + ├───┤ + │ │ + ├───┤ ┌───┐ + │ │ already │ │ + ├───┤ fetched ├───┤ + │ │ blocks │ │ + ├───┤ ├───┤ + │ │ │░◉░│ ◄ fetch range + ───┴───┴─────┬───┬─────┼───┼─── + │░◉░│ ◄ │░░░│ + └───┘ ├───┤ + │░◉░│ ◄ + └───┘ + +In earlier versions of this scheme we maintained and relied on the invariant +that the ranges of fetched blocks are backwards closed. This meant we never had +discontinuous ranges of fetched or not-yet-fetched blocks. This invariant does +simplify things somewhat by keeping the ranges continuous however it precludes +fetching ranges of blocks from different peers in parallel. + +We do not maintain any such invariant and so we have to deal with there being +gaps in the ranges we have already fetched or are yet to fetch. To keep the +tracking simple we do not track the ranges themselves, rather we track the set +of individual blocks without their relationship to each other. + +-} + +-- | Find the fragments of the chain suffix that we still need to fetch, these +-- are the fragments covering blocks that have not yet been fetched and are +-- not currently in the process of being fetched from this peer. +-- +-- Typically this is a single fragment forming a suffix of the chain, but in +-- the general case we can get a bunch of discontiguous chain fragments. +-- +filterNotAlreadyFetched + :: (HasHeader header, HeaderHash header ~ HeaderHash block) + => (Point block -> Bool) + -> MaxSlotNo + -> [(FetchDecision (ChainSuffix header), peerinfo)] + -> [(FetchDecision (CandidateFragments header), peerinfo)] +filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo chains = + [ (mcandidates, peer) + | (mcandidate, peer) <- chains + , let mcandidates = do + candidate <- mcandidate + let fragments = filterWithMaxSlotNo + notAlreadyFetched + fetchedMaxSlotNo + (getChainSuffix candidate) + guard (not (null fragments)) ?! FetchDeclineAlreadyFetched + return (candidate, fragments) + ] + where + notAlreadyFetched = not . alreadyDownloaded . castPoint . blockPoint + +filterNotAlreadyInFlightWithPeer + :: HasHeader header + => [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, + peerinfo)] + -> [(FetchDecision (CandidateFragments header), peerinfo)] +filterNotAlreadyInFlightWithPeer chains = + [ (mcandidatefragments', peer) + | (mcandidatefragments, inflight, peer) <- chains + , let mcandidatefragments' = do + (candidate, chainfragments) <- mcandidatefragments + let fragments = concatMap (filterWithMaxSlotNo + (notAlreadyInFlight inflight) + (peerFetchMaxSlotNo inflight)) + chainfragments + guard (not (null fragments)) ?! FetchDeclineInFlightThisPeer + return (candidate, fragments) + ] + where + notAlreadyInFlight inflight b = + blockPoint b `Set.notMember` peerFetchBlocksInFlight inflight + +-- | The \"oh noes?!\" operator. +-- +-- In the case of an error, the operator provides a specific error value. +-- +(?!) :: Maybe a -> e -> Either e a +Just x ?! _ = Right x +Nothing ?! e = Left e + +-- | Filter a fragment. This is an optimised variant that will behave the same +-- as 'AnchoredFragment.filter' if the following precondition is satisfied: +-- +-- PRECONDITION: for all @hdr@ in the chain fragment: if @blockSlot hdr > +-- maxSlotNo@ then the predicate should not hold for any header after @hdr@ in +-- the chain fragment. +-- +-- For example, when filtering out already downloaded blocks from the +-- fragment, it does not make sense to keep filtering after having encountered +-- the highest slot number the ChainDB has seen so far: blocks with a greater +-- slot number cannot have been downloaded yet. When the candidate fragments +-- get far ahead of the current chain, e.g., @2k@ headers, this optimisation +-- avoids the linear cost of filtering these headers when we know in advance +-- they will all remain in the final fragment. In case the given slot number +-- is 'NoSlotNo', no filtering takes place, as there should be no matches +-- because we haven't downloaded any blocks yet. +-- +-- For example, when filtering out blocks already in-flight for the given +-- peer, the given @maxSlotNo@ can correspond to the block with the highest +-- slot number that so far has been in-flight for the given peer. When no +-- blocks have been in-flight yet, @maxSlotNo@ can be 'NoSlotNo', in which +-- case no filtering needs to take place, which makes sense, as there are no +-- blocks to filter out. Note that this is conservative: if a block is for +-- some reason multiple times in-flight (maybe it has to be redownloaded) and +-- the block's slot number matches the @maxSlotNo@, it will now be filtered +-- (while the filtering might previously have stopped before encountering the +-- block in question). This is fine, as the filter will now include the block, +-- because according to the filtering predicate, the block is not in-flight. +filterWithMaxSlotNo + :: forall header. HasHeader header + => (header -> Bool) + -> MaxSlotNo -- ^ @maxSlotNo@ + -> AnchoredFragment header + -> [AnchoredFragment header] +filterWithMaxSlotNo p maxSlotNo = + AF.filterWithStop p ((> maxSlotNo) . MaxSlotNo . blockSlot) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index 12a8fbae920..49d4096dcf1 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -11,12 +11,9 @@ module Ouroboros.Network.BlockFetch.Decision.Deadline ( -- * Deciding what to fetch fetchDecisionsDeadline -- ** Components of the decision-making process - , filterPlausibleCandidates , selectForkSuffixes , filterNotAlreadyFetched - , filterNotAlreadyInFlightWithPeer , prioritisePeerChains - , filterNotAlreadyInFlightWithOtherPeers , fetchRequestDecisions ) where @@ -46,26 +43,6 @@ import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), import Ouroboros.Network.BlockFetch.Decision.Common --- | The \"oh noes?!\" operator. --- --- In the case of an error, the operator provides a specific error value. --- -(?!) :: Maybe a -> e -> Either e a -Just x ?! _ = Right x -Nothing ?! e = Left e - --- | The combination of a 'ChainSuffix' and a list of discontiguous --- 'AnchoredFragment's: --- --- * When comparing two 'CandidateFragments' as candidate chains, we use the --- 'ChainSuffix'. --- --- * To track which blocks of that candidate still have to be downloaded, we --- use a list of discontiguous 'AnchoredFragment's. --- -type CandidateFragments header = (ChainSuffix header, [AnchoredFragment header]) - - fetchDecisionsDeadline :: (Ord peer, Hashable peer, @@ -94,11 +71,6 @@ fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { FetchModeDeadline . map swizzleSIG - -- Filter to keep blocks that are not already in-flight with other peers. - . filterNotAlreadyInFlightWithOtherPeers - FetchModeDeadline - . map swizzleSI - -- Reorder chains based on consensus policy and network timing data. . prioritisePeerChains FetchModeDeadline @@ -128,107 +100,8 @@ fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { -- Data swizzling functions to get the right info into each stage. swizzleI (c, p@(_, inflight,_,_, _)) = (c, inflight, p) swizzleIG (c, p@(_, inflight,gsvs,peer,_)) = (c, inflight, gsvs, peer, p) - swizzleSI (c, p@(status,inflight,_,_, _)) = (c, status, inflight, p) swizzleSIG (c, p@(status,inflight,gsvs,peer,_)) = (c, status, inflight, gsvs, peer, p) -{- -We have the node's /current/ or /adopted/ chain. This is the node's chain in -the sense specified by the Ouroboros algorithm. It is a fully verified chain -with block bodies and a ledger state. - - ┆ ┆ - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ │ - ───┴───┴─── current chain length (block number) - -With chain selection we are interested in /candidate/ chains. We have these -candidate chains in the form of chains of verified headers, but without bodies. - -The consensus layer gives us the current set of candidate chains from our peers -and we have the task of selecting which block bodies to download, and then -passing those block bodes back to the consensus layer. The consensus layer will -try to validate them and decide if it wants to update its current chain. - - ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ └───┘ - │ │ │ │ │ │ │ │ - ───┴───┴─────┼───┼─────┼───┼─────┼───┼───────────── current chain length - │ │ │ │ │ │ - current ├───┤ ├───┤ └───┘ - (blocks) │ │ │ │ - └───┘ └───┘ - A B C D - candidates - (headers) - -In this example we have four candidate chains, with all but chain D strictly -longer than our current chain. - -In general there are many candidate chains. We make a distinction between a -candidate chain and the peer from which it is available. It is often the -case that the same chain is available from multiple peers. We will try to be -clear about when we are referring to chains or the combination of a chain and -the peer from which it is available. - -For the sake of the example let us assume we have the four chains above -available from the following peers. - -peer 1 2 3 4 5 6 7 - ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ └───┘ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ │ │ - ──┼───┼─────┼───┼─────┼───┼─────┼───┼───────────────┼───┼─────┼───┼── - │ │ │ │ │ │ │ │ │ │ │ │ - └───┘ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - └───┘ └───┘ └───┘ └───┘ └───┘ -chain C A B A D B A - -This is the form in which we are informed about candidate chains from the -consensus layer, the combination of a chain and the peer it is from. This -makes sense, since these things change independently. - -We will process the chains in this form, keeping the peer/chain combination all -the way through. Although there could in principle be some opportunistic saving -by sharing when multiple peers provide the same chain, taking advantage of this -adds complexity and does nothing to improve our worst case costs. - -We are only interested in candidate chains that are strictly longer than our -current chain. So our first task is to filter down to this set. --} - - --- | Keep only those candidate chains that are preferred over the current --- chain. Typically, this means that their length is longer than the length of --- the current chain. --- -filterPlausibleCandidates - :: (AnchoredFragment block -> AnchoredFragment header -> Bool) - -> AnchoredFragment block -- ^ The current chain - -> [(AnchoredFragment header, peerinfo)] - -> [(FetchDecision (AnchoredFragment header), peerinfo)] -filterPlausibleCandidates plausibleCandidateChain currentChain chains = - [ (chain', peer) - | (chain, peer) <- chains - , let chain' = do - guard (plausibleCandidateChain currentChain chain) - ?! FetchDeclineChainNotPlausible - return chain - ] {- @@ -251,44 +124,6 @@ chain C A B A B A -} -{- -Of course we would at most need to download the blocks in a candidate chain -that are not already in the current chain. So we must find those intersections. - -Before we do that, lets define how we represent a suffix of a chain. We do this -very simply as a chain fragment: exactly those blocks contained in the suffix. -A chain fragment is of course not a chain, but has many similar invariants. - -We will later also need to represent chain ranges when we send block fetch -requests. We do this using a pair of points: the first and last blocks in the -range. While we can represent an empty chain fragment, we cannot represent an -empty fetch range, but this is ok since we never request empty ranges. - - Chain fragment - ┌───┐ - │ ◉ │ Start of range, inclusive - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ ◉ │ End of range, inclusive. - └───┘ --} - --- | A chain suffix, obtained by intersecting a candidate chain with the --- current chain. --- --- The anchor point of a 'ChainSuffix' will be a point within the bounds of --- the current chain ('AF.withinFragmentBounds'), indicating that it forks off --- in the last @K@ blocks. --- --- A 'ChainSuffix' must be non-empty, as an empty suffix, i.e. the candidate --- chain is equal to the current chain, would not be a plausible candidate. -newtype ChainSuffix header = - ChainSuffix { getChainSuffix :: AnchoredFragment header } {- We define the /chain suffix/ as the suffix of the candidate chain up until (but @@ -354,177 +189,6 @@ selectForkSuffixes current chains = chainForkSuffix current chain ?! FetchDeclineChainIntersectionTooDeep ] -{- -We define the /fetch range/ as the suffix of the fork range that has not yet -had its blocks downloaded and block content checked against the headers. - - ┆ ┆ - ├───┤ - │ │ - ├───┤ ┌───┐ - │ │ already │ │ - ├───┤ fetched ├───┤ - │ │ blocks │ │ - ├───┤ ├───┤ - │ │ │░◉░│ ◄ fetch range - ───┴───┴─────┬───┬─────┼───┼─── - │░◉░│ ◄ │░░░│ - └───┘ ├───┤ - │░◉░│ ◄ - └───┘ - -In earlier versions of this scheme we maintained and relied on the invariant -that the ranges of fetched blocks are backwards closed. This meant we never had -discontinuous ranges of fetched or not-yet-fetched blocks. This invariant does -simplify things somewhat by keeping the ranges continuous however it precludes -fetching ranges of blocks from different peers in parallel. - -We do not maintain any such invariant and so we have to deal with there being -gaps in the ranges we have already fetched or are yet to fetch. To keep the -tracking simple we do not track the ranges themselves, rather we track the set -of individual blocks without their relationship to each other. - --} - --- | Find the fragments of the chain suffix that we still need to fetch, these --- are the fragments covering blocks that have not yet been fetched and are --- not currently in the process of being fetched from this peer. --- --- Typically this is a single fragment forming a suffix of the chain, but in --- the general case we can get a bunch of discontiguous chain fragments. --- -filterNotAlreadyFetched - :: (HasHeader header, HeaderHash header ~ HeaderHash block) - => (Point block -> Bool) - -> MaxSlotNo - -> [(FetchDecision (ChainSuffix header), peerinfo)] - -> [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo chains = - [ (mcandidates, peer) - | (mcandidate, peer) <- chains - , let mcandidates = do - candidate <- mcandidate - let fragments = filterWithMaxSlotNo - notAlreadyFetched - fetchedMaxSlotNo - (getChainSuffix candidate) - guard (not (null fragments)) ?! FetchDeclineAlreadyFetched - return (candidate, fragments) - ] - where - notAlreadyFetched = not . alreadyDownloaded . castPoint . blockPoint - - -filterNotAlreadyInFlightWithPeer - :: HasHeader header - => [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, - peerinfo)] - -> [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyInFlightWithPeer chains = - [ (mcandidatefragments', peer) - | (mcandidatefragments, inflight, peer) <- chains - , let mcandidatefragments' = do - (candidate, chainfragments) <- mcandidatefragments - let fragments = concatMap (filterWithMaxSlotNo - (notAlreadyInFlight inflight) - (peerFetchMaxSlotNo inflight)) - chainfragments - guard (not (null fragments)) ?! FetchDeclineInFlightThisPeer - return (candidate, fragments) - ] - where - notAlreadyInFlight inflight b = - blockPoint b `Set.notMember` peerFetchBlocksInFlight inflight - - --- | A penultimate step of filtering, but this time across peers, rather than --- individually for each peer. If we're following the parallel fetch --- mode then we filter out blocks that are already in-flight with other --- peers. --- --- Note that this does /not/ cover blocks that are proposed to be fetched in --- this round of decisions. That step is covered in 'fetchRequestDecisions'. --- -filterNotAlreadyInFlightWithOtherPeers - :: HasHeader header - => FetchMode - -> [( FetchDecision [AnchoredFragment header] - , PeerFetchStatus header - , PeerFetchInFlight header - , peerinfo )] - -> [(FetchDecision [AnchoredFragment header], peerinfo)] - -filterNotAlreadyInFlightWithOtherPeers FetchModeDeadline chains = - [ (mchainfragments, peer) - | (mchainfragments, _, _, peer) <- chains ] - -filterNotAlreadyInFlightWithOtherPeers FetchModeBulkSync chains = - [ (mcandidatefragments', peer) - | (mcandidatefragments, _, _, peer) <- chains - , let mcandidatefragments' = do - chainfragments <- mcandidatefragments - let fragments = concatMap (filterWithMaxSlotNo - notAlreadyInFlight - maxSlotNoInFlightWithOtherPeers) - chainfragments - guard (not (null fragments)) ?! FetchDeclineInFlightOtherPeer - return fragments - ] - where - notAlreadyInFlight b = - blockPoint b `Set.notMember` blocksInFlightWithOtherPeers - - -- All the blocks that are already in-flight with all peers - blocksInFlightWithOtherPeers = - Set.unions - [ case status of - PeerFetchStatusShutdown -> Set.empty - PeerFetchStatusStarting -> Set.empty - PeerFetchStatusAberrant -> Set.empty - _other -> peerFetchBlocksInFlight inflight - | (_, status, inflight, _) <- chains ] - - -- The highest slot number that is or has been in flight for any peer. - maxSlotNoInFlightWithOtherPeers = foldl' max NoMaxSlotNo - [ peerFetchMaxSlotNo inflight | (_, _, inflight, _) <- chains ] - --- | Filter a fragment. This is an optimised variant that will behave the same --- as 'AnchoredFragment.filter' if the following precondition is satisfied: --- --- PRECONDITION: for all @hdr@ in the chain fragment: if @blockSlot hdr > --- maxSlotNo@ then the predicate should not hold for any header after @hdr@ in --- the chain fragment. --- --- For example, when filtering out already downloaded blocks from the --- fragment, it does not make sense to keep filtering after having encountered --- the highest slot number the ChainDB has seen so far: blocks with a greater --- slot number cannot have been downloaded yet. When the candidate fragments --- get far ahead of the current chain, e.g., @2k@ headers, this optimisation --- avoids the linear cost of filtering these headers when we know in advance --- they will all remain in the final fragment. In case the given slot number --- is 'NoSlotNo', no filtering takes place, as there should be no matches --- because we haven't downloaded any blocks yet. --- --- For example, when filtering out blocks already in-flight for the given --- peer, the given @maxSlotNo@ can correspond to the block with the highest --- slot number that so far has been in-flight for the given peer. When no --- blocks have been in-flight yet, @maxSlotNo@ can be 'NoSlotNo', in which --- case no filtering needs to take place, which makes sense, as there are no --- blocks to filter out. Note that this is conservative: if a block is for --- some reason multiple times in-flight (maybe it has to be redownloaded) and --- the block's slot number matches the @maxSlotNo@, it will now be filtered --- (while the filtering might previously have stopped before encountering the --- block in question). This is fine, as the filter will now include the block, --- because according to the filtering predicate, the block is not in-flight. -filterWithMaxSlotNo - :: forall header. HasHeader header - => (header -> Bool) - -> MaxSlotNo -- ^ @maxSlotNo@ - -> AnchoredFragment header - -> [AnchoredFragment header] -filterWithMaxSlotNo p maxSlotNo = - AF.filterWithStop p ((> maxSlotNo) . MaxSlotNo . blockSlot) - prioritisePeerChains :: forall extra header peer. ( HasHeader header From 9771ed0c94c0b093c00fbcad92d30c55cd88390e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 6 Jun 2024 10:24:03 +0000 Subject: [PATCH 003/136] =?UTF-8?q?Note=20on=20=E2=80=9Cbulk=20sync?= =?UTF-8?q?=E2=80=9D?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index c804383819c..befe85e015e 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -19,6 +19,8 @@ import Ouroboros.Network.Block import Ouroboros.Network.SizeInBytes (SizeInBytes) +-- REVIEW: “Bulk Sync” is really not bulk anymore, so maybe we should rename +-- this? Just “Sync”? Maybe “Genesis Sync”? data FetchMode = -- | Use this mode when we are catching up on the chain but are stil -- well behind. In this mode the fetch logic will optimise for From 9b3693a3197b372f01bb37653e544ea952f34a0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 10 Jun 2024 07:49:34 +0000 Subject: [PATCH 004/136] Get longest candidate --- .../Network/BlockFetch/Decision/BulkSync.hs | 30 +++++++++---------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 30f00776720..d7fa7c68532 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -6,20 +6,23 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync , filterNotAlreadyInFlightWithOtherPeers) where -import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import Control.Monad (guard) +import Data.List (foldl', sortOn) +import Data.Ord (Down(Down)) +import qualified Data.Set as Set + +import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..)) import Ouroboros.Network.BlockFetch.Decision.Common -import Control.Monad (guard) -import qualified Data.Set as Set -import Data.List (foldl', singleton) -- REVIEW: We should not import anything from 'Decision.Deadline'; if the need -- arises, we should move the interesting piece of code to 'Decision.Common'. -- This is to be done on demand. fetchDecisionsBulkSync :: + HasHeader header => FetchDecisionPolicy header -> AnchoredFragment header -> (Point block -> Bool) @@ -28,21 +31,16 @@ fetchDecisionsBulkSync :: -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisionsBulkSync - _fetchDecisionPolicy@FetchDecisionPolicy { - plausibleCandidateChain - } - currentChain + _fetchDecisionPolicy + _currentChain _fetchedBlocks _fetchedMaxSlotNo + candidatesAndPeers = - map (\(fd, peer) -> - (FetchRequest . singleton <$> fd, peer) - ) - - -- First, filter to keep chains the consensus layer tells us are plausible. - . filterPlausibleCandidates - plausibleCandidateChain - currentChain + case sortOn (Down . headBlockNo) $ map fst candidatesAndPeers of + [] -> error "fetchDecisionsBulkSync: empty list of candidates" + _candidate : _ -> + undefined -- | A penultimate step of filtering, but this time across peers, rather than -- individually for each peer. If we're following the parallel fetch From 5e4a6651e3556f16eb92922cde8d303a620cfe4b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 10 Jun 2024 08:03:57 +0000 Subject: [PATCH 005/136] Break down `filterNotAlreadyFetched` in two functions --- .../Network/BlockFetch/Decision/Common.hs | 41 ++++++++----------- .../Network/BlockFetch/Decision/Deadline.hs | 13 +++++- 2 files changed, 29 insertions(+), 25 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index d099238087e..7000ed5a31a 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -19,16 +19,17 @@ module Ouroboros.Network.BlockFetch.Decision.Common ( ) where import GHC.Stack (HasCallStack) +import Control.Monad (guard) import Control.Monad.Class.MonadTime.SI (DiffTime) +import qualified Data.Set as Set + import Ouroboros.Network.AnchoredFragment (AnchoredFragment) -import Ouroboros.Network.SizeInBytes ( SizeInBytes ) +import qualified Ouroboros.Network.AnchoredFragment as AF +import Ouroboros.Network.Block (HasHeader, HeaderHash, Point, MaxSlotNo (..), castPoint, blockPoint, blockSlot) import Ouroboros.Network.BlockFetch.ClientState (PeerFetchInFlight (..), PeerFetchStatus (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) import Ouroboros.Network.DeltaQ ( PeerGSV ) -import Ouroboros.Network.Block (HasHeader, HeaderHash, Point, MaxSlotNo (..), castPoint, blockPoint, blockSlot) -import Control.Monad (guard) -import qualified Ouroboros.Network.AnchoredFragment as AF -import qualified Data.Set as Set +import Ouroboros.Network.SizeInBytes ( SizeInBytes ) data FetchDecisionPolicy header = FetchDecisionPolicy { maxInFlightReqsPerPeer :: Word, -- A protocol constant. @@ -391,26 +392,18 @@ of individual blocks without their relationship to each other. -- -- Typically this is a single fragment forming a suffix of the chain, but in -- the general case we can get a bunch of discontiguous chain fragments. --- -filterNotAlreadyFetched - :: (HasHeader header, HeaderHash header ~ HeaderHash block) - => (Point block -> Bool) - -> MaxSlotNo - -> [(FetchDecision (ChainSuffix header), peerinfo)] - -> [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo chains = - [ (mcandidates, peer) - | (mcandidate, peer) <- chains - , let mcandidates = do - candidate <- mcandidate - let fragments = filterWithMaxSlotNo - notAlreadyFetched - fetchedMaxSlotNo - (getChainSuffix candidate) - guard (not (null fragments)) ?! FetchDeclineAlreadyFetched - return (candidate, fragments) - ] +filterNotAlreadyFetched :: + (HasHeader header, HeaderHash header ~ HeaderHash block) => + (Point block -> Bool) -> + MaxSlotNo -> + ChainSuffix header -> + FetchDecision (CandidateFragments header) +filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo candidate = + if null fragments + then Left FetchDeclineAlreadyFetched + else Right (candidate, fragments) where + fragments = filterWithMaxSlotNo notAlreadyFetched fetchedMaxSlotNo (getChainSuffix candidate) notAlreadyFetched = not . alreadyDownloaded . castPoint . blockPoint filterNotAlreadyInFlightWithPeer diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index 49d4096dcf1..bc476a0ff1f 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -84,7 +84,7 @@ fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { . map swizzleI -- Filter to keep blocks that have not already been downloaded. - . filterNotAlreadyFetched + . filterNotAlreadyFetched' fetchedBlocks fetchedMaxSlotNo @@ -102,6 +102,17 @@ fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { swizzleIG (c, p@(_, inflight,gsvs,peer,_)) = (c, inflight, gsvs, peer, p) swizzleSIG (c, p@(status,inflight,gsvs,peer,_)) = (c, status, inflight, gsvs, peer, p) +filterNotAlreadyFetched' :: + (HasHeader header, HeaderHash header ~ HeaderHash block) => + (Point block -> Bool) -> + MaxSlotNo -> + [(FetchDecision (ChainSuffix header), peerinfo)] -> + [(FetchDecision (CandidateFragments header), peerinfo)] +filterNotAlreadyFetched' alreadyDownloaded fetchedMaxSlotNo = + map + ( \(mcandidate, peer) -> + ((filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo =<< mcandidate), peer) + ) {- From cc12e86d61e5020ba782c5af4a783b9d6e80cd26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 10 Jun 2024 08:10:32 +0000 Subject: [PATCH 006/136] Break down `filterNotAlreadyInFlightWithPeer` in two functions --- .../Network/BlockFetch/Decision/Common.hs | 30 +++++++------------ .../Network/BlockFetch/Decision/Deadline.hs | 11 ++++++- 2 files changed, 21 insertions(+), 20 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index 7000ed5a31a..691b86c9b89 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -406,26 +406,18 @@ filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo candidate = fragments = filterWithMaxSlotNo notAlreadyFetched fetchedMaxSlotNo (getChainSuffix candidate) notAlreadyFetched = not . alreadyDownloaded . castPoint . blockPoint -filterNotAlreadyInFlightWithPeer - :: HasHeader header - => [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, - peerinfo)] - -> [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyInFlightWithPeer chains = - [ (mcandidatefragments', peer) - | (mcandidatefragments, inflight, peer) <- chains - , let mcandidatefragments' = do - (candidate, chainfragments) <- mcandidatefragments - let fragments = concatMap (filterWithMaxSlotNo - (notAlreadyInFlight inflight) - (peerFetchMaxSlotNo inflight)) - chainfragments - guard (not (null fragments)) ?! FetchDeclineInFlightThisPeer - return (candidate, fragments) - ] +filterNotAlreadyInFlightWithPeer :: + (HasHeader header) => + PeerFetchInFlight header -> + CandidateFragments header -> + FetchDecision (CandidateFragments header) +filterNotAlreadyInFlightWithPeer inflight (candidate, chainfragments) = + if null fragments + then Left FetchDeclineInFlightThisPeer + else Right (candidate, fragments) where - notAlreadyInFlight inflight b = - blockPoint b `Set.notMember` peerFetchBlocksInFlight inflight + fragments = concatMap (filterWithMaxSlotNo notAlreadyInFlight (peerFetchMaxSlotNo inflight)) chainfragments + notAlreadyInFlight b = blockPoint b `Set.notMember` peerFetchBlocksInFlight inflight -- | The \"oh noes?!\" operator. -- diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index bc476a0ff1f..d100fee9766 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -80,7 +80,7 @@ fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { . map swizzleIG -- Filter to keep blocks that are not already in-flight for this peer. - . filterNotAlreadyInFlightWithPeer + . filterNotAlreadyInFlightWithPeer' . map swizzleI -- Filter to keep blocks that have not already been downloaded. @@ -114,6 +114,15 @@ filterNotAlreadyFetched' alreadyDownloaded fetchedMaxSlotNo = ((filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo =<< mcandidate), peer) ) +filterNotAlreadyInFlightWithPeer' :: + (HasHeader header) => + [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, peerinfo)] -> + [(FetchDecision (CandidateFragments header), peerinfo)] +filterNotAlreadyInFlightWithPeer' = + map + ( \(mcandidatefragments, inflight, peer) -> + ((filterNotAlreadyInFlightWithPeer inflight =<< mcandidatefragments), peer) + ) {- In the example, this leaves us with only the candidate chains: A, B and C, but From 47bd5c3f76d7422915dc08394dcbf96803836f86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 10 Jun 2024 09:07:00 +0000 Subject: [PATCH 007/136] More work on bulk sync block fetch --- .../Ouroboros/Network/BlockFetch/Decision.hs | 5 +- .../Network/BlockFetch/Decision/BulkSync.hs | 45 ++++++++++---- .../Network/BlockFetch/Decision/Common.hs | 59 +++++++++++++++++++ .../Network/BlockFetch/Decision/Deadline.hs | 57 ------------------ 4 files changed, 96 insertions(+), 70 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 2561969bec4..5190a3b6d05 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -30,8 +30,9 @@ import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), - filterPlausibleCandidates, filterNotAlreadyFetched, filterNotAlreadyInFlightWithPeer) -import Ouroboros.Network.BlockFetch.Decision.Deadline (fetchDecisionsDeadline, selectForkSuffixes, + filterPlausibleCandidates, filterNotAlreadyFetched, filterNotAlreadyInFlightWithPeer, + selectForkSuffixes) +import Ouroboros.Network.BlockFetch.Decision.Deadline (fetchDecisionsDeadline, prioritisePeerChains, fetchRequestDecisions) import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSync, filterNotAlreadyInFlightWithOtherPeers) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index d7fa7c68532..fd322a4f63f 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} -- | This module contains the part of the block fetch decisions process that is -- specific to the bulk sync mode. @@ -7,6 +8,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( , filterNotAlreadyInFlightWithOtherPeers) where import Control.Monad (guard) +import Data.Bifunctor (first) import Data.List (foldl', sortOn) import Data.Ord (Down(Down)) import qualified Data.Set as Set @@ -21,9 +23,10 @@ import Ouroboros.Network.BlockFetch.Decision.Common -- arises, we should move the interesting piece of code to 'Decision.Common'. -- This is to be done on demand. -fetchDecisionsBulkSync :: - HasHeader header => - FetchDecisionPolicy header +fetchDecisionsBulkSync + :: (HasHeader header, + HeaderHash header ~ HeaderHash block) + =>FetchDecisionPolicy header -> AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo @@ -32,15 +35,35 @@ fetchDecisionsBulkSync :: fetchDecisionsBulkSync _fetchDecisionPolicy - _currentChain - _fetchedBlocks - _fetchedMaxSlotNo - candidatesAndPeers + currentChain + fetchedBlocks + fetchedMaxSlotNo = - case sortOn (Down . headBlockNo) $ map fst candidatesAndPeers of - [] -> error "fetchDecisionsBulkSync: empty list of candidates" - _candidate : _ -> - undefined + -- FIXME: Wrap in a 'FetchRequest'. + map (first ((FetchRequest . snd) <$>)) + + -- Filter to keep blocks that are not already in-flight for this peer. + . filterNotAlreadyInFlightWithPeer' + . map swizzleI + + -- Filter to keep blocks that have not already been downloaded. + . filterNotAlreadyFetched' + fetchedBlocks + fetchedMaxSlotNo + + -- Select the suffix up to the intersection with the current chain. + . selectForkSuffixes + currentChain + + -- FIXME: Wrap in a 'FetchDecision'. + . map (first pure) + + -- Sort the candidates by descending block number of their heads, that is + -- consider longest fragments first. + . sortOn (Down . headBlockNo . fst) + where + -- Data swizzling functions to get the right info into each stage. + swizzleI (c, p@(_, inflight,_,_, _)) = (c, inflight, p) -- | A penultimate step of filtering, but this time across peers, rather than -- individually for each peer. If we're following the parallel fetch diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index 691b86c9b89..5360fa836b0 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -16,9 +16,13 @@ module Ouroboros.Network.BlockFetch.Decision.Common ( , CandidateFragments , filterWithMaxSlotNo , filterPlausibleCandidates + , selectForkSuffixes + , filterNotAlreadyInFlightWithPeer' + , filterNotAlreadyFetched' ) where import GHC.Stack (HasCallStack) +import Control.Exception (assert) import Control.Monad (guard) import Control.Monad.Class.MonadTime.SI (DiffTime) import qualified Data.Set as Set @@ -406,6 +410,18 @@ filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo candidate = fragments = filterWithMaxSlotNo notAlreadyFetched fetchedMaxSlotNo (getChainSuffix candidate) notAlreadyFetched = not . alreadyDownloaded . castPoint . blockPoint +filterNotAlreadyFetched' :: + (HasHeader header, HeaderHash header ~ HeaderHash block) => + (Point block -> Bool) -> + MaxSlotNo -> + [(FetchDecision (ChainSuffix header), peerinfo)] -> + [(FetchDecision (CandidateFragments header), peerinfo)] +filterNotAlreadyFetched' alreadyDownloaded fetchedMaxSlotNo = + map + ( \(mcandidate, peer) -> + ((filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo =<< mcandidate), peer) + ) + filterNotAlreadyInFlightWithPeer :: (HasHeader header) => PeerFetchInFlight header -> @@ -419,6 +435,16 @@ filterNotAlreadyInFlightWithPeer inflight (candidate, chainfragments) = fragments = concatMap (filterWithMaxSlotNo notAlreadyInFlight (peerFetchMaxSlotNo inflight)) chainfragments notAlreadyInFlight b = blockPoint b `Set.notMember` peerFetchBlocksInFlight inflight +filterNotAlreadyInFlightWithPeer' :: + (HasHeader header) => + [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, peerinfo)] -> + [(FetchDecision (CandidateFragments header), peerinfo)] +filterNotAlreadyInFlightWithPeer' = + map + ( \(mcandidatefragments, inflight, peer) -> + ((filterNotAlreadyInFlightWithPeer inflight =<< mcandidatefragments), peer) + ) + -- | The \"oh noes?!\" operator. -- -- In the case of an error, the operator provides a specific error value. @@ -463,3 +489,36 @@ filterWithMaxSlotNo -> [AnchoredFragment header] filterWithMaxSlotNo p maxSlotNo = AF.filterWithStop p ((> maxSlotNo) . MaxSlotNo . blockSlot) + +-- | Find the chain suffix for a candidate chain, with respect to the +-- current chain. +-- +chainForkSuffix + :: (HasHeader header, HasHeader block, + HeaderHash header ~ HeaderHash block) + => AnchoredFragment block -- ^ Current chain. + -> AnchoredFragment header -- ^ Candidate chain + -> Maybe (ChainSuffix header) +chainForkSuffix current candidate = + case AF.intersect current candidate of + Nothing -> Nothing + Just (_, _, _, candidateSuffix) -> + -- If the suffix is empty, it means the candidate chain was equal to + -- the current chain and didn't fork off. Such a candidate chain is + -- not a plausible candidate, so it must have been filtered out. + assert (not (AF.null candidateSuffix)) $ + Just (ChainSuffix candidateSuffix) + +selectForkSuffixes + :: (HasHeader header, HasHeader block, + HeaderHash header ~ HeaderHash block) + => AnchoredFragment block + -> [(FetchDecision (AnchoredFragment header), peerinfo)] + -> [(FetchDecision (ChainSuffix header), peerinfo)] +selectForkSuffixes current chains = + [ (mchain', peer) + | (mchain, peer) <- chains + , let mchain' = do + chain <- mchain + chainForkSuffix current chain ?! FetchDeclineChainIntersectionTooDeep + ] diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index d100fee9766..6c7e3ac1ca1 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -11,8 +11,6 @@ module Ouroboros.Network.BlockFetch.Decision.Deadline ( -- * Deciding what to fetch fetchDecisionsDeadline -- ** Components of the decision-making process - , selectForkSuffixes - , filterNotAlreadyFetched , prioritisePeerChains , fetchRequestDecisions ) where @@ -102,28 +100,6 @@ fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { swizzleIG (c, p@(_, inflight,gsvs,peer,_)) = (c, inflight, gsvs, peer, p) swizzleSIG (c, p@(status,inflight,gsvs,peer,_)) = (c, status, inflight, gsvs, peer, p) -filterNotAlreadyFetched' :: - (HasHeader header, HeaderHash header ~ HeaderHash block) => - (Point block -> Bool) -> - MaxSlotNo -> - [(FetchDecision (ChainSuffix header), peerinfo)] -> - [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyFetched' alreadyDownloaded fetchedMaxSlotNo = - map - ( \(mcandidate, peer) -> - ((filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo =<< mcandidate), peer) - ) - -filterNotAlreadyInFlightWithPeer' :: - (HasHeader header) => - [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, peerinfo)] -> - [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyInFlightWithPeer' = - map - ( \(mcandidatefragments, inflight, peer) -> - ((filterNotAlreadyInFlightWithPeer inflight =<< mcandidatefragments), peer) - ) - {- In the example, this leaves us with only the candidate chains: A, B and C, but still paired up with the various peers. @@ -176,39 +152,6 @@ blocks. This means the candidate forks by more than K and so we are not interested in this candidate at all. -} --- | Find the chain suffix for a candidate chain, with respect to the --- current chain. --- -chainForkSuffix - :: (HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) - => AnchoredFragment block -- ^ Current chain. - -> AnchoredFragment header -- ^ Candidate chain - -> Maybe (ChainSuffix header) -chainForkSuffix current candidate = - case AF.intersect current candidate of - Nothing -> Nothing - Just (_, _, _, candidateSuffix) -> - -- If the suffix is empty, it means the candidate chain was equal to - -- the current chain and didn't fork off. Such a candidate chain is - -- not a plausible candidate, so it must have been filtered out. - assert (not (AF.null candidateSuffix)) $ - Just (ChainSuffix candidateSuffix) - -selectForkSuffixes - :: (HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) - => AnchoredFragment block - -> [(FetchDecision (AnchoredFragment header), peerinfo)] - -> [(FetchDecision (ChainSuffix header), peerinfo)] -selectForkSuffixes current chains = - [ (mchain', peer) - | (mchain, peer) <- chains - , let mchain' = do - chain <- mchain - chainForkSuffix current chain ?! FetchDeclineChainIntersectionTooDeep - ] - prioritisePeerChains :: forall extra header peer. ( HasHeader header From 1cd371e9154ead00a35500c82e16da4fbb2a8e25 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 10 Jun 2024 09:32:32 +0000 Subject: [PATCH 008/136] Filter plausible and in flight with other peer --- .../Network/BlockFetch/Decision/BulkSync.hs | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index fd322a4f63f..c40a97606a7 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -34,13 +34,17 @@ fetchDecisionsBulkSync -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisionsBulkSync - _fetchDecisionPolicy + _fetchDecisionPolicy@FetchDecisionPolicy{plausibleCandidateChain} currentChain fetchedBlocks fetchedMaxSlotNo = -- FIXME: Wrap in a 'FetchRequest'. - map (first ((FetchRequest . snd) <$>)) + map (first (fmap FetchRequest)) + + -- Filter to keep blocks that are not already in-flight with other peers. + . filterNotAlreadyInFlightWithOtherPeers + . map (swizzleSI . first (fmap snd)) -- Filter to keep blocks that are not already in-flight for this peer. . filterNotAlreadyInFlightWithPeer' @@ -55,8 +59,10 @@ fetchDecisionsBulkSync . selectForkSuffixes currentChain - -- FIXME: Wrap in a 'FetchDecision'. - . map (first pure) + -- Filter to keep chains the consensus layer tells us are plausible. + . filterPlausibleCandidates + plausibleCandidateChain + currentChain -- Sort the candidates by descending block number of their heads, that is -- consider longest fragments first. @@ -64,6 +70,7 @@ fetchDecisionsBulkSync where -- Data swizzling functions to get the right info into each stage. swizzleI (c, p@(_, inflight,_,_, _)) = (c, inflight, p) + swizzleSI (c, p@(status,inflight,_,_, _)) = (c, status, inflight, p) -- | A penultimate step of filtering, but this time across peers, rather than -- individually for each peer. If we're following the parallel fetch From 18e2fed0b7766030d3b35f030b106a9f5ce821c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 10 Jun 2024 09:49:56 +0000 Subject: [PATCH 009/136] Yay movin' forward --- .../Network/BlockFetch/Decision/BulkSync.hs | 104 ++++++++++++------ 1 file changed, 70 insertions(+), 34 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index c40a97606a7..a727d0105a6 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -17,6 +17,7 @@ import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.Decision.Common -- REVIEW: We should not import anything from 'Decision.Deadline'; if the need @@ -34,43 +35,78 @@ fetchDecisionsBulkSync -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisionsBulkSync - _fetchDecisionPolicy@FetchDecisionPolicy{plausibleCandidateChain} + _fetchDecisionPolicy@FetchDecisionPolicy {plausibleCandidateChain} currentChain fetchedBlocks fetchedMaxSlotNo - = - -- FIXME: Wrap in a 'FetchRequest'. - map (first (fmap FetchRequest)) - - -- Filter to keep blocks that are not already in-flight with other peers. - . filterNotAlreadyInFlightWithOtherPeers - . map (swizzleSI . first (fmap snd)) - - -- Filter to keep blocks that are not already in-flight for this peer. - . filterNotAlreadyInFlightWithPeer' - . map swizzleI - - -- Filter to keep blocks that have not already been downloaded. - . filterNotAlreadyFetched' - fetchedBlocks - fetchedMaxSlotNo - - -- Select the suffix up to the intersection with the current chain. - . selectForkSuffixes - currentChain - - -- Filter to keep chains the consensus layer tells us are plausible. - . filterPlausibleCandidates - plausibleCandidateChain - currentChain - - -- Sort the candidates by descending block number of their heads, that is - -- consider longest fragments first. - . sortOn (Down . headBlockNo . fst) - where - -- Data swizzling functions to get the right info into each stage. - swizzleI (c, p@(_, inflight,_,_, _)) = (c, inflight, p) - swizzleSI (c, p@(status,inflight,_,_, _)) = (c, status, inflight, p) + candidatesAndPeers = + -- Sort candidates from longest to shortest and filter out all unplausible + -- candidates. This gives a list of already-declined candidates and a list + -- of plausible candidates. + let (declinedCandidates, candidates) = + partitionEithersFirst + -- Filter to keep chains the consensus layer tells us are plausible. + . filterPlausibleCandidates + plausibleCandidateChain + currentChain + -- Sort the candidates by descending block number of their heads, that is + -- consider longest fragments first. + . sortOn (Down . headBlockNo . fst) + $ candidatesAndPeers + declinedCandidates' = map (first Left) declinedCandidates + in + -- If there are no candidates remaining, we are done. Otherwise, pick the + -- first one and try to fetch it. Decline all the others. + case candidates of + [] -> declinedCandidates' + ((theCandidate, _thePeer) : otherCandidates) -> + let declinedOtherCandidates = map (first (const (Left (FetchDeclineConcurrencyLimit FetchModeBulkSync 1)))) otherCandidates + in fetchTheCandidate + candidatesAndPeers + theCandidate + : (declinedCandidates' ++ declinedOtherCandidates) + where + partitionEithersFirst :: [(Either a b, c)] -> ([(a, c)], [(b, c)]) + partitionEithersFirst = + foldr + ( \(e, c) (as, bs) -> case e of + Left a -> ((a, c) : as, bs) + Right b -> (as, (b, c) : bs) + ) + ([], []) + +fetchTheCandidate :: + -- (HasHeader header, HeaderHash header ~ HeaderHash block) => + [(AnchoredFragment header, PeerInfo header peer extra)] -> + AnchoredFragment header -> + (FetchDecision (FetchRequest header), PeerInfo header peer extra) +fetchTheCandidate _candidatesAndPeers _theCandidate = + undefined + +-- -- FIXME: Wrap in a 'FetchRequest'. + -- map (first (fmap FetchRequest)) + + -- -- Filter to keep blocks that are not already in-flight with other peers. + -- . filterNotAlreadyInFlightWithOtherPeers + -- . map (swizzleSI . first (fmap snd)) + + -- -- Filter to keep blocks that are not already in-flight for this peer. + -- . filterNotAlreadyInFlightWithPeer' + -- . map swizzleI + + -- -- Filter to keep blocks that have not already been downloaded. + -- . filterNotAlreadyFetched' + -- fetchedBlocks + -- fetchedMaxSlotNo + + -- -- Select the suffix up to the intersection with the current chain. + -- . selectForkSuffixes + -- currentChain + + -- where + -- -- Data swizzling functions to get the right info into each stage. + -- swizzleI (c, p@(_, inflight,_,_, _)) = (c, inflight, p) + -- swizzleSI (c, p@(status,inflight,_,_, _)) = (c, status, inflight, p) -- | A penultimate step of filtering, but this time across peers, rather than -- individually for each peer. If we're following the parallel fetch From 837d0170917eb6f374eddaefd5269b2595511b7a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 10 Jun 2024 10:04:34 +0000 Subject: [PATCH 010/136] Choose the candidate to get and try to fetch it ...except the fetch function is not implemented yet --- .../Network/BlockFetch/Decision/BulkSync.hs | 63 ++++++++++--------- 1 file changed, 35 insertions(+), 28 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index a727d0105a6..196202557d4 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -24,16 +24,17 @@ import Ouroboros.Network.BlockFetch.Decision.Common -- arises, we should move the interesting piece of code to 'Decision.Common'. -- This is to be done on demand. -fetchDecisionsBulkSync - :: (HasHeader header, - HeaderHash header ~ HeaderHash block) - =>FetchDecisionPolicy header - -> AnchoredFragment header - -> (Point block -> Bool) - -> MaxSlotNo - -> [(AnchoredFragment header, PeerInfo header peer extra)] - -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] - +fetchDecisionsBulkSync :: + ( HasHeader header, + HeaderHash header ~ HeaderHash block, + Eq peer + ) => + FetchDecisionPolicy header -> + AnchoredFragment header -> + (Point block -> Bool) -> + MaxSlotNo -> + [(AnchoredFragment header, PeerInfo header peer extra)] -> + [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisionsBulkSync _fetchDecisionPolicy@FetchDecisionPolicy {plausibleCandidateChain} currentChain @@ -45,6 +46,9 @@ fetchDecisionsBulkSync -- of plausible candidates. let (declinedCandidates, candidates) = partitionEithersFirst + -- Select the suffix up to the intersection with the current chain. + . selectForkSuffixes + currentChain -- Filter to keep chains the consensus layer tells us are plausible. . filterPlausibleCandidates plausibleCandidateChain @@ -53,18 +57,23 @@ fetchDecisionsBulkSync -- consider longest fragments first. . sortOn (Down . headBlockNo . fst) $ candidatesAndPeers - declinedCandidates' = map (first Left) declinedCandidates - in - -- If there are no candidates remaining, we are done. Otherwise, pick the - -- first one and try to fetch it. Decline all the others. - case candidates of - [] -> declinedCandidates' - ((theCandidate, _thePeer) : otherCandidates) -> - let declinedOtherCandidates = map (first (const (Left (FetchDeclineConcurrencyLimit FetchModeBulkSync 1)))) otherCandidates - in fetchTheCandidate - candidatesAndPeers - theCandidate - : (declinedCandidates' ++ declinedOtherCandidates) + in -- If there are no candidates remaining, we are done. Otherwise, pick the + -- first one and try to fetch it. Decline all the others. + map (first Left) declinedCandidates + ++ case candidates of + [] -> [] + ((candidate, peer) : otherCandidates) -> + case fetchTheCandidate candidatesAndPeers candidate of + Left declined -> + -- If fetching the candidate did not work, report the reason and + -- decline all the others for concurrency reasons. + (Left declined, peer) : declineConcurrent otherCandidates + Right (theRequest, thePeer) -> + -- If fetching the candidate _did_ work, then we have a request + -- potentially for another peer, so we report this request and + -- decline all the peers except for that specific one. + (Right theRequest, thePeer) + : filter ((not . eqPeerInfo thePeer) . snd) (declineConcurrent candidates) where partitionEithersFirst :: [(Either a b, c)] -> ([(a, c)], [(b, c)]) partitionEithersFirst = @@ -74,12 +83,14 @@ fetchDecisionsBulkSync Right b -> (as, (b, c) : bs) ) ([], []) + declineConcurrent = map (first (const (Left (FetchDeclineConcurrencyLimit FetchModeBulkSync 1)))) + eqPeerInfo (_, _, _, p1, _) (_, _, _, p2, _) = p1 == p2 fetchTheCandidate :: -- (HasHeader header, HeaderHash header ~ HeaderHash block) => [(AnchoredFragment header, PeerInfo header peer extra)] -> - AnchoredFragment header -> - (FetchDecision (FetchRequest header), PeerInfo header peer extra) + ChainSuffix header -> + FetchDecision ((FetchRequest header), PeerInfo header peer extra) fetchTheCandidate _candidatesAndPeers _theCandidate = undefined @@ -99,10 +110,6 @@ fetchTheCandidate _candidatesAndPeers _theCandidate = -- fetchedBlocks -- fetchedMaxSlotNo - -- -- Select the suffix up to the intersection with the current chain. - -- . selectForkSuffixes - -- currentChain - -- where -- -- Data swizzling functions to get the right info into each stage. -- swizzleI (c, p@(_, inflight,_,_, _)) = (c, inflight, p) From 3d71e47effa28de6939aa90ff25e330d18088914 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 10 Jun 2024 10:43:50 +0000 Subject: [PATCH 011/136] Getting there --- .../Ouroboros/Network/BlockFetch/Decision.hs | 3 +- .../Network/BlockFetch/Decision/BulkSync.hs | 98 ++++++++----------- 2 files changed, 40 insertions(+), 61 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 5190a3b6d05..67cc5405741 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -19,7 +19,6 @@ module Ouroboros.Network.BlockFetch.Decision , filterNotAlreadyFetched , filterNotAlreadyInFlightWithPeer , prioritisePeerChains - , filterNotAlreadyInFlightWithOtherPeers , fetchRequestDecisions ) where @@ -34,7 +33,7 @@ import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), P selectForkSuffixes) import Ouroboros.Network.BlockFetch.Decision.Deadline (fetchDecisionsDeadline, prioritisePeerChains, fetchRequestDecisions) -import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSync, filterNotAlreadyInFlightWithOtherPeers) +import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSync) fetchDecisions :: (Ord peer, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 196202557d4..5d795b2a31f 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -5,9 +5,8 @@ -- specific to the bulk sync mode. module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync -, filterNotAlreadyInFlightWithOtherPeers) where +) where -import Control.Monad (guard) import Data.Bifunctor (first) import Data.List (foldl', sortOn) import Data.Ord (Down(Down)) @@ -46,9 +45,9 @@ fetchDecisionsBulkSync -- of plausible candidates. let (declinedCandidates, candidates) = partitionEithersFirst - -- Select the suffix up to the intersection with the current chain. + -- Select the suffix up to the intersection with the current chain. . selectForkSuffixes - currentChain + currentChain -- Filter to keep chains the consensus layer tells us are plausible. . filterPlausibleCandidates plausibleCandidateChain @@ -63,7 +62,11 @@ fetchDecisionsBulkSync ++ case candidates of [] -> [] ((candidate, peer) : otherCandidates) -> - case fetchTheCandidate candidatesAndPeers candidate of + case fetchTheCandidate + fetchedBlocks + fetchedMaxSlotNo + candidatesAndPeers + candidate of Left declined -> -- If fetching the candidate did not work, report the reason and -- decline all the others for concurrency reasons. @@ -87,33 +90,24 @@ fetchDecisionsBulkSync eqPeerInfo (_, _, _, p1, _) (_, _, _, p2, _) = p1 == p2 fetchTheCandidate :: - -- (HasHeader header, HeaderHash header ~ HeaderHash block) => + ( HasHeader header, + HeaderHash header ~ HeaderHash block + ) => + (Point block -> Bool) -> + MaxSlotNo -> [(AnchoredFragment header, PeerInfo header peer extra)] -> ChainSuffix header -> FetchDecision ((FetchRequest header), PeerInfo header peer extra) -fetchTheCandidate _candidatesAndPeers _theCandidate = - undefined - --- -- FIXME: Wrap in a 'FetchRequest'. - -- map (first (fmap FetchRequest)) - - -- -- Filter to keep blocks that are not already in-flight with other peers. - -- . filterNotAlreadyInFlightWithOtherPeers - -- . map (swizzleSI . first (fmap snd)) - - -- -- Filter to keep blocks that are not already in-flight for this peer. - -- . filterNotAlreadyInFlightWithPeer' - -- . map swizzleI - - -- -- Filter to keep blocks that have not already been downloaded. - -- . filterNotAlreadyFetched' - -- fetchedBlocks - -- fetchedMaxSlotNo - - -- where - -- -- Data swizzling functions to get the right info into each stage. - -- swizzleI (c, p@(_, inflight,_,_, _)) = (c, inflight, p) - -- swizzleSI (c, p@(status,inflight,_,_, _)) = (c, status, inflight, p) +fetchTheCandidate fetchedBlocks fetchedMaxSlotNo candidatesAndPeers chainSuffix = + do + -- Filter to keep blocks that have not already been downloaded or that are + -- not already in-flight with any peer. + fragments <- + filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo chainSuffix + >>= filterNotAlreadyInFlightWithAnyPeer statusInflightInfo + pure undefined + where + statusInflightInfo = map (\(_, (status,inflight,_,_,_)) -> (status,inflight)) candidatesAndPeers -- | A penultimate step of filtering, but this time across peers, rather than -- individually for each peer. If we're following the parallel fetch @@ -122,41 +116,27 @@ fetchTheCandidate _candidatesAndPeers _theCandidate = -- -- Note that this does /not/ cover blocks that are proposed to be fetched in -- this round of decisions. That step is covered in 'fetchRequestDecisions'. --- -filterNotAlreadyInFlightWithOtherPeers - :: HasHeader header - => [( FetchDecision [AnchoredFragment header] - , PeerFetchStatus header - , PeerFetchInFlight header - , peerinfo )] - -> [(FetchDecision [AnchoredFragment header], peerinfo)] - -filterNotAlreadyInFlightWithOtherPeers chains = - [ (mcandidatefragments', peer) - | (mcandidatefragments, _, _, peer) <- chains - , let mcandidatefragments' = do - chainfragments <- mcandidatefragments - let fragments = concatMap (filterWithMaxSlotNo - notAlreadyInFlight - maxSlotNoInFlightWithOtherPeers) - chainfragments - guard (not (null fragments)) ?! FetchDeclineInFlightOtherPeer - return fragments - ] +filterNotAlreadyInFlightWithAnyPeer :: + (HasHeader header) => + [(PeerFetchStatus header, PeerFetchInFlight header)] -> + CandidateFragments header -> + FetchDecision [AnchoredFragment header] +filterNotAlreadyInFlightWithAnyPeer statusInflightInfos chainfragments = + if null fragments + then Left FetchDeclineInFlightOtherPeer + else Right fragments where - notAlreadyInFlight b = - blockPoint b `Set.notMember` blocksInFlightWithOtherPeers - - -- All the blocks that are already in-flight with all peers + fragments = concatMap (filterWithMaxSlotNo notAlreadyInFlight maxSlotNoInFlight) $ snd chainfragments + notAlreadyInFlight b = blockPoint b `Set.notMember` blocksInFlightWithOtherPeers + -- All the blocks that are already in-flight with all peers blocksInFlightWithOtherPeers = Set.unions [ case status of PeerFetchStatusShutdown -> Set.empty PeerFetchStatusStarting -> Set.empty PeerFetchStatusAberrant -> Set.empty - _other -> peerFetchBlocksInFlight inflight - | (_, status, inflight, _) <- chains ] - + _other -> peerFetchBlocksInFlight inflight + | (status, inflight) <- statusInflightInfos + ] -- The highest slot number that is or has been in flight for any peer. - maxSlotNoInFlightWithOtherPeers = foldl' max NoMaxSlotNo - [ peerFetchMaxSlotNo inflight | (_, _, inflight, _) <- chains ] + maxSlotNoInFlight = foldl' max NoMaxSlotNo (map (peerFetchMaxSlotNo . snd) statusInflightInfos) From 86fccf6444c6bfa1b249753ea59a2591d5396e75 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 10 Jun 2024 10:47:45 +0000 Subject: [PATCH 012/136] Move `fetchRequestDecision` to `Common` ... but not `fetchRequestDecisions` that still belongs to the deadline mode: the bulksync mode is only interested in deciding for one candidate. --- .../Network/BlockFetch/Decision/Common.hs | 149 ++++++++++++++++- .../Network/BlockFetch/Decision/Deadline.hs | 150 +----------------- 2 files changed, 149 insertions(+), 150 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index 5360fa836b0..5f7cf572573 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | This module contains the part of the block fetch decisions process that is -- common to both the bulk sync and deadline modes. @@ -19,6 +20,7 @@ module Ouroboros.Network.BlockFetch.Decision.Common ( , selectForkSuffixes , filterNotAlreadyInFlightWithPeer' , filterNotAlreadyFetched' + , fetchRequestDecision ) where import GHC.Stack (HasCallStack) @@ -27,13 +29,14 @@ import Control.Monad (guard) import Control.Monad.Class.MonadTime.SI (DiffTime) import qualified Data.Set as Set -import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq (..)) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (HasHeader, HeaderHash, Point, MaxSlotNo (..), castPoint, blockPoint, blockSlot) -import Ouroboros.Network.BlockFetch.ClientState (PeerFetchInFlight (..), PeerFetchStatus (..)) +import Ouroboros.Network.BlockFetch.ClientState (PeerFetchInFlight (..), PeerFetchStatus (..), FetchRequest (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) import Ouroboros.Network.DeltaQ ( PeerGSV ) import Ouroboros.Network.SizeInBytes ( SizeInBytes ) +import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..)) data FetchDecisionPolicy header = FetchDecisionPolicy { maxInFlightReqsPerPeer :: Word, -- A protocol constant. @@ -522,3 +525,145 @@ selectForkSuffixes current chains = chain <- mchain chainForkSuffix current chain ?! FetchDeclineChainIntersectionTooDeep ] + +fetchRequestDecision + :: HasHeader header + => FetchDecisionPolicy header + -> FetchMode + -> Word + -> PeerFetchInFlightLimits + -> PeerFetchInFlight header + -> PeerFetchStatus header + -> FetchDecision [AnchoredFragment header] + -> FetchDecision (FetchRequest header) + +fetchRequestDecision _ _ _ _ _ _ (Left decline) + = Left decline + +fetchRequestDecision _ _ _ _ _ PeerFetchStatusShutdown _ + = Left FetchDeclinePeerShutdown + +fetchRequestDecision _ _ _ _ _ PeerFetchStatusStarting _ + = Left FetchDeclinePeerStarting + +fetchRequestDecision _ _ _ _ _ PeerFetchStatusAberrant _ + = Left FetchDeclinePeerSlow + +fetchRequestDecision FetchDecisionPolicy { + maxConcurrencyBulkSync, + maxConcurrencyDeadline, + maxInFlightReqsPerPeer, + blockFetchSize + } + fetchMode + nConcurrentFetchPeers + PeerFetchInFlightLimits { + inFlightBytesLowWatermark, + inFlightBytesHighWatermark + } + PeerFetchInFlight { + peerFetchReqsInFlight, + peerFetchBytesInFlight + } + peerFetchStatus + (Right fetchFragments) + + | peerFetchReqsInFlight >= maxInFlightReqsPerPeer + = Left $ FetchDeclineReqsInFlightLimit + maxInFlightReqsPerPeer + + | peerFetchBytesInFlight >= inFlightBytesHighWatermark + = Left $ FetchDeclineBytesInFlightLimit + peerFetchBytesInFlight + inFlightBytesLowWatermark + inFlightBytesHighWatermark + + -- This covers the case when we could still fit in more reqs or bytes, but + -- we want to let it drop below a low water mark before sending more so we + -- get a bit more batching behaviour, rather than lots of 1-block reqs. + | peerFetchStatus == PeerFetchStatusBusy + = Left $ FetchDeclinePeerBusy + peerFetchBytesInFlight + inFlightBytesLowWatermark + inFlightBytesHighWatermark + + -- Refuse any blockrequest if we're above the concurrency limit. + | let maxConcurrentFetchPeers = case fetchMode of + FetchModeBulkSync -> maxConcurrencyBulkSync + FetchModeDeadline -> maxConcurrencyDeadline + , nConcurrentFetchPeers > maxConcurrentFetchPeers + = Left $ FetchDeclineConcurrencyLimit + fetchMode maxConcurrentFetchPeers + + -- If we're at the concurrency limit refuse any additional peers. + | peerFetchReqsInFlight == 0 + , let maxConcurrentFetchPeers = case fetchMode of + FetchModeBulkSync -> maxConcurrencyBulkSync + FetchModeDeadline -> maxConcurrencyDeadline + , nConcurrentFetchPeers == maxConcurrentFetchPeers + = Left $ FetchDeclineConcurrencyLimit + fetchMode maxConcurrentFetchPeers + + -- We've checked our request limit and our byte limit. We are then + -- guaranteed to get at least one non-empty request range. + | otherwise + = assert (peerFetchReqsInFlight < maxInFlightReqsPerPeer) $ + assert (not (null fetchFragments)) $ + + Right $ selectBlocksUpToLimits + blockFetchSize + peerFetchReqsInFlight + maxInFlightReqsPerPeer + peerFetchBytesInFlight + inFlightBytesHighWatermark + fetchFragments + +-- | +-- +-- Precondition: The result will be non-empty if +-- +-- Property: result is non-empty if preconditions satisfied +-- +selectBlocksUpToLimits + :: forall header. HasHeader header + => (header -> SizeInBytes) -- ^ Block body size + -> Word -- ^ Current number of requests in flight + -> Word -- ^ Maximum number of requests in flight allowed + -> SizeInBytes -- ^ Current number of bytes in flight + -> SizeInBytes -- ^ Maximum number of bytes in flight allowed + -> [AnchoredFragment header] + -> FetchRequest header +selectBlocksUpToLimits blockFetchSize nreqs0 maxreqs nbytes0 maxbytes fragments = + assert (nreqs0 < maxreqs && nbytes0 < maxbytes && not (null fragments)) $ + -- The case that we are already over our limits has to be checked earlier, + -- outside of this function. From here on however we check for limits. + + let fragments' = goFrags nreqs0 nbytes0 fragments in + assert (all (not . AF.null) fragments') $ + FetchRequest fragments' + where + goFrags :: Word + -> SizeInBytes + -> [AnchoredFragment header] -> [AnchoredFragment header] + goFrags _ _ [] = [] + goFrags nreqs nbytes (c:cs) + | nreqs+1 > maxreqs = [] + | otherwise = goFrag (nreqs+1) nbytes (Empty (AF.anchor c)) c cs + -- Each time we have to pick from a new discontiguous chain fragment then + -- that will become a new request, which contributes to our in-flight + -- request count. We never break the maxreqs limit. + + goFrag :: Word + -> SizeInBytes + -> AnchoredFragment header + -> AnchoredFragment header + -> [AnchoredFragment header] -> [AnchoredFragment header] + goFrag nreqs nbytes c' (Empty _) cs = c' : goFrags nreqs nbytes cs + goFrag nreqs nbytes c' (b :< c) cs + | nbytes' >= maxbytes = [c' :> b] + | otherwise = goFrag nreqs nbytes' (c' :> b) c cs + where + nbytes' = nbytes + blockFetchSize b + -- Note that we always pick the one last block that crosses the maxbytes + -- limit. This cover the case where we otherwise wouldn't even be able to + -- request a single block, as it's too large. diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index 6c7e3ac1ca1..03d1c43805e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -23,10 +23,9 @@ import Data.List (foldl', groupBy, sortBy, transpose) import Data.Maybe (mapMaybe) import Data.Set (Set) -import Control.Exception (assert) import Control.Monad (guard) -import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq (..)) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.AnchoredFragment qualified as AF import Ouroboros.Network.Block import Ouroboros.Network.Point (withOriginToMaybe) @@ -34,8 +33,7 @@ import Ouroboros.Network.Point (withOriginToMaybe) import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) -import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), - PeerGSV (..), SizeInBytes, calculatePeerFetchInFlightLimits, +import Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..), SizeInBytes, calculatePeerFetchInFlightLimits, comparePeerGSV, comparePeerGSV', estimateExpectedResponseDuration, estimateResponseDeadlineProbability) @@ -450,147 +448,3 @@ fetchRequestDecisions fetchDecisionPolicy fetchMode chains = case fetchMode of FetchModeBulkSync -> maxConcurrencyBulkSync fetchDecisionPolicy FetchModeDeadline -> maxConcurrencyDeadline fetchDecisionPolicy - - -fetchRequestDecision - :: HasHeader header - => FetchDecisionPolicy header - -> FetchMode - -> Word - -> PeerFetchInFlightLimits - -> PeerFetchInFlight header - -> PeerFetchStatus header - -> FetchDecision [AnchoredFragment header] - -> FetchDecision (FetchRequest header) - -fetchRequestDecision _ _ _ _ _ _ (Left decline) - = Left decline - -fetchRequestDecision _ _ _ _ _ PeerFetchStatusShutdown _ - = Left FetchDeclinePeerShutdown - -fetchRequestDecision _ _ _ _ _ PeerFetchStatusStarting _ - = Left FetchDeclinePeerStarting - -fetchRequestDecision _ _ _ _ _ PeerFetchStatusAberrant _ - = Left FetchDeclinePeerSlow - -fetchRequestDecision FetchDecisionPolicy { - maxConcurrencyBulkSync, - maxConcurrencyDeadline, - maxInFlightReqsPerPeer, - blockFetchSize - } - fetchMode - nConcurrentFetchPeers - PeerFetchInFlightLimits { - inFlightBytesLowWatermark, - inFlightBytesHighWatermark - } - PeerFetchInFlight { - peerFetchReqsInFlight, - peerFetchBytesInFlight - } - peerFetchStatus - (Right fetchFragments) - - | peerFetchReqsInFlight >= maxInFlightReqsPerPeer - = Left $ FetchDeclineReqsInFlightLimit - maxInFlightReqsPerPeer - - | peerFetchBytesInFlight >= inFlightBytesHighWatermark - = Left $ FetchDeclineBytesInFlightLimit - peerFetchBytesInFlight - inFlightBytesLowWatermark - inFlightBytesHighWatermark - - -- This covers the case when we could still fit in more reqs or bytes, but - -- we want to let it drop below a low water mark before sending more so we - -- get a bit more batching behaviour, rather than lots of 1-block reqs. - | peerFetchStatus == PeerFetchStatusBusy - = Left $ FetchDeclinePeerBusy - peerFetchBytesInFlight - inFlightBytesLowWatermark - inFlightBytesHighWatermark - - -- Refuse any blockrequest if we're above the concurrency limit. - | let maxConcurrentFetchPeers = case fetchMode of - FetchModeBulkSync -> maxConcurrencyBulkSync - FetchModeDeadline -> maxConcurrencyDeadline - , nConcurrentFetchPeers > maxConcurrentFetchPeers - = Left $ FetchDeclineConcurrencyLimit - fetchMode maxConcurrentFetchPeers - - -- If we're at the concurrency limit refuse any additional peers. - | peerFetchReqsInFlight == 0 - , let maxConcurrentFetchPeers = case fetchMode of - FetchModeBulkSync -> maxConcurrencyBulkSync - FetchModeDeadline -> maxConcurrencyDeadline - , nConcurrentFetchPeers == maxConcurrentFetchPeers - = Left $ FetchDeclineConcurrencyLimit - fetchMode maxConcurrentFetchPeers - - -- We've checked our request limit and our byte limit. We are then - -- guaranteed to get at least one non-empty request range. - | otherwise - = assert (peerFetchReqsInFlight < maxInFlightReqsPerPeer) $ - assert (not (null fetchFragments)) $ - - Right $ selectBlocksUpToLimits - blockFetchSize - peerFetchReqsInFlight - maxInFlightReqsPerPeer - peerFetchBytesInFlight - inFlightBytesHighWatermark - fetchFragments - - --- | --- --- Precondition: The result will be non-empty if --- --- Property: result is non-empty if preconditions satisfied --- -selectBlocksUpToLimits - :: forall header. HasHeader header - => (header -> SizeInBytes) -- ^ Block body size - -> Word -- ^ Current number of requests in flight - -> Word -- ^ Maximum number of requests in flight allowed - -> SizeInBytes -- ^ Current number of bytes in flight - -> SizeInBytes -- ^ Maximum number of bytes in flight allowed - -> [AnchoredFragment header] - -> FetchRequest header -selectBlocksUpToLimits blockFetchSize nreqs0 maxreqs nbytes0 maxbytes fragments = - assert (nreqs0 < maxreqs && nbytes0 < maxbytes && not (null fragments)) $ - -- The case that we are already over our limits has to be checked earlier, - -- outside of this function. From here on however we check for limits. - - let fragments' = goFrags nreqs0 nbytes0 fragments in - assert (all (not . AF.null) fragments') $ - FetchRequest fragments' - where - goFrags :: Word - -> SizeInBytes - -> [AnchoredFragment header] -> [AnchoredFragment header] - goFrags _ _ [] = [] - goFrags nreqs nbytes (c:cs) - | nreqs+1 > maxreqs = [] - | otherwise = goFrag (nreqs+1) nbytes (AF.Empty (AF.anchor c)) c cs - -- Each time we have to pick from a new discontiguous chain fragment then - -- that will become a new request, which contributes to our in-flight - -- request count. We never break the maxreqs limit. - - goFrag :: Word - -> SizeInBytes - -> AnchoredFragment header - -> AnchoredFragment header - -> [AnchoredFragment header] -> [AnchoredFragment header] - goFrag nreqs nbytes c' (Empty _) cs = c' : goFrags nreqs nbytes cs - goFrag nreqs nbytes c' (b :< c) cs - | nbytes' >= maxbytes = [c' :> b] - | otherwise = goFrag nreqs nbytes' (c' :> b) c cs - where - nbytes' = nbytes + blockFetchSize b - -- Note that we always pick the one last block that crosses the maxbytes - -- limit. This cover the case where we otherwise wouldn't even be able to - -- request a single block, as it's too large. From 69b7c287ce4335c3c0a85f759d0c6f8cf0ade5dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 10 Jun 2024 11:33:43 +0000 Subject: [PATCH 013/136] First implementation of a naive bulk sync decision logic --- .../Network/BlockFetch/Decision/BulkSync.hs | 56 +++++++++++++++---- .../Network/BlockFetch/Decision/Common.hs | 7 ++- 2 files changed, 49 insertions(+), 14 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 5d795b2a31f..1355e88faa3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} -- | This module contains the part of the block fetch decisions process that is -- specific to the bulk sync mode. @@ -7,6 +8,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync ) where +import Cardano.Prelude (maybeToEither) import Data.Bifunctor (first) import Data.List (foldl', sortOn) import Data.Ord (Down(Down)) @@ -17,6 +19,7 @@ import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) +import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Ouroboros.Network.BlockFetch.Decision.Common -- REVIEW: We should not import anything from 'Decision.Deadline'; if the need @@ -35,7 +38,7 @@ fetchDecisionsBulkSync :: [(AnchoredFragment header, PeerInfo header peer extra)] -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisionsBulkSync - _fetchDecisionPolicy@FetchDecisionPolicy {plausibleCandidateChain} + fetchDecisionPolicy@FetchDecisionPolicy {plausibleCandidateChain} currentChain fetchedBlocks fetchedMaxSlotNo @@ -63,6 +66,7 @@ fetchDecisionsBulkSync [] -> [] ((candidate, peer) : otherCandidates) -> case fetchTheCandidate + fetchDecisionPolicy fetchedBlocks fetchedMaxSlotNo candidatesAndPeers @@ -93,21 +97,51 @@ fetchTheCandidate :: ( HasHeader header, HeaderHash header ~ HeaderHash block ) => + FetchDecisionPolicy header -> (Point block -> Bool) -> MaxSlotNo -> [(AnchoredFragment header, PeerInfo header peer extra)] -> ChainSuffix header -> FetchDecision ((FetchRequest header), PeerInfo header peer extra) -fetchTheCandidate fetchedBlocks fetchedMaxSlotNo candidatesAndPeers chainSuffix = - do - -- Filter to keep blocks that have not already been downloaded or that are - -- not already in-flight with any peer. - fragments <- - filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo chainSuffix - >>= filterNotAlreadyInFlightWithAnyPeer statusInflightInfo - pure undefined - where - statusInflightInfo = map (\(_, (status,inflight,_,_,_)) -> (status,inflight)) candidatesAndPeers +fetchTheCandidate + fetchDecisionPolicy + fetchedBlocks + fetchedMaxSlotNo + candidatesAndPeers + chainSuffix = + do + -- Filter to keep blocks that have not already been downloaded or that are + -- not already in-flight with any peer. + fragments <- + filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo chainSuffix + >>= filterNotAlreadyInFlightWithAnyPeer statusInflightInfo + -- For each peer, try to create a request for those fragments. Then take + -- the first one that is successful. + maybeToEither FetchDeclineAlreadyFetched $ + firstRight $ + map + ( \(_, peerInfo@(status, inflight, gsvs, _, _)) -> + -- let fragments' = filterWithMaxSlotNo (not . blockAlreadyFetched) fragments + -- in (FetchRequest fragments', peer) + (,peerInfo) + <$> fetchRequestDecision + fetchDecisionPolicy + FetchModeBulkSync + nConcurrentFetchPeers + (calculatePeerFetchInFlightLimits gsvs) + inflight + status + (Right fragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. + ) + candidatesAndPeers + where + statusInflightInfo = map (\(_, (status, inflight, _, _, _)) -> (status, inflight)) candidatesAndPeers + nConcurrentFetchPeers = + -- REVIEW: A bit weird considering that this should be '0' or '1'. + fromIntegral $ length $ filter (\(_, inflight) -> peerFetchReqsInFlight inflight > 0) statusInflightInfo + firstRight [] = Nothing + firstRight (Right x : _) = Just x + firstRight (Left _ : xs) = firstRight xs -- | A penultimate step of filtering, but this time across peers, rather than -- individually for each peer. If we're following the parallel fetch diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index 5f7cf572573..1e6f8041a77 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -531,6 +531,8 @@ fetchRequestDecision => FetchDecisionPolicy header -> FetchMode -> Word + -- ^ Number of concurrent fetch peers. Can be set to @0@ to bypass + -- concurrency limits. -> PeerFetchInFlightLimits -> PeerFetchInFlight header -> PeerFetchStatus header @@ -550,7 +552,6 @@ fetchRequestDecision _ _ _ _ _ PeerFetchStatusAberrant _ = Left FetchDeclinePeerSlow fetchRequestDecision FetchDecisionPolicy { - maxConcurrencyBulkSync, maxConcurrencyDeadline, maxInFlightReqsPerPeer, blockFetchSize @@ -589,7 +590,7 @@ fetchRequestDecision FetchDecisionPolicy { -- Refuse any blockrequest if we're above the concurrency limit. | let maxConcurrentFetchPeers = case fetchMode of - FetchModeBulkSync -> maxConcurrencyBulkSync + FetchModeBulkSync -> 1 -- FIXME: maxConcurrencyBulkSync has to be removed from the interface FetchModeDeadline -> maxConcurrencyDeadline , nConcurrentFetchPeers > maxConcurrentFetchPeers = Left $ FetchDeclineConcurrencyLimit @@ -598,7 +599,7 @@ fetchRequestDecision FetchDecisionPolicy { -- If we're at the concurrency limit refuse any additional peers. | peerFetchReqsInFlight == 0 , let maxConcurrentFetchPeers = case fetchMode of - FetchModeBulkSync -> maxConcurrencyBulkSync + FetchModeBulkSync -> 1 -- FIXME: maxConcurrencyBulkSync has to be removed from the interface FetchModeDeadline -> maxConcurrencyDeadline , nConcurrentFetchPeers == maxConcurrentFetchPeers = Left $ FetchDeclineConcurrencyLimit From d5b5fd269fcb653a61f485c0f5630f8afb4a0d06 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 12 Jun 2024 11:21:38 +0000 Subject: [PATCH 014/136] Some notes here and there --- .../Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 8 +++++--- .../src/Ouroboros/Network/BlockFetch/Decision/Common.hs | 9 +++++++-- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 1355e88faa3..235b49336a3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -80,7 +80,7 @@ fetchDecisionsBulkSync -- potentially for another peer, so we report this request and -- decline all the peers except for that specific one. (Right theRequest, thePeer) - : filter ((not . eqPeerInfo thePeer) . snd) (declineConcurrent candidates) + : filter (not . eqPeerInfo thePeer . snd) (declineConcurrent candidates) where partitionEithersFirst :: [(Either a b, c)] -> ([(a, c)], [(b, c)]) partitionEithersFirst = @@ -121,8 +121,10 @@ fetchTheCandidate firstRight $ map ( \(_, peerInfo@(status, inflight, gsvs, _, _)) -> - -- let fragments' = filterWithMaxSlotNo (not . blockAlreadyFetched) fragments - -- in (FetchRequest fragments', peer) + -- FIXME: 'fetchRequestDecisions' does not check whether the + -- peer _could_ serve the given blocks, so we need to trim the + -- fragments to only contain blocks that are in the peer's + -- candidate fragment. (,peerInfo) <$> fetchRequestDecision fetchDecisionPolicy diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index 1e6f8041a77..3ea01ce2442 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -526,6 +526,11 @@ selectForkSuffixes current chains = chainForkSuffix current chain ?! FetchDeclineChainIntersectionTooDeep ] +-- | +-- +-- This function _does not_ check if the peer is likely to have the blocks in +-- the ranges, it only compute a request that respect what the peer's current +-- status indicates on their ability to fulfill it. fetchRequestDecision :: HasHeader header => FetchDecisionPolicy header @@ -574,7 +579,7 @@ fetchRequestDecision FetchDecisionPolicy { maxInFlightReqsPerPeer | peerFetchBytesInFlight >= inFlightBytesHighWatermark - = Left $ FetchDeclineBytesInFlightLimit + = Left $ FetchDeclineBytesInFlightLimit -- FIXME: this one should be maybe not too bad. peerFetchBytesInFlight inFlightBytesLowWatermark inFlightBytesHighWatermark @@ -583,7 +588,7 @@ fetchRequestDecision FetchDecisionPolicy { -- we want to let it drop below a low water mark before sending more so we -- get a bit more batching behaviour, rather than lots of 1-block reqs. | peerFetchStatus == PeerFetchStatusBusy - = Left $ FetchDeclinePeerBusy + = Left $ FetchDeclinePeerBusy -- FIXME: also not too bad peerFetchBytesInFlight inFlightBytesLowWatermark inFlightBytesHighWatermark From bc07066f51f653171075a7ebd6668c4bc6d6d106 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 12 Jun 2024 13:14:53 +0000 Subject: [PATCH 015/136] Better filtering of peers if they don't provide the fragments --- .../Network/BlockFetch/Decision/BulkSync.hs | 114 ++++++++++++------ 1 file changed, 79 insertions(+), 35 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 235b49336a3..7ba737d6da4 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -8,13 +8,16 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync ) where -import Cardano.Prelude (maybeToEither) +import Cardano.Prelude (rightToMaybe, mapMaybe) import Data.Bifunctor (first) import Data.List (foldl', sortOn) +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE import Data.Ord (Down(Down)) import qualified Data.Set as Set import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) +import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..)) @@ -64,18 +67,21 @@ fetchDecisionsBulkSync map (first Left) declinedCandidates ++ case candidates of [] -> [] - ((candidate, peer) : otherCandidates) -> + ((candidate, _) : _) -> case fetchTheCandidate fetchDecisionPolicy fetchedBlocks fetchedMaxSlotNo candidatesAndPeers candidate of - Left declined -> - -- If fetching the candidate did not work, report the reason and - -- decline all the others for concurrency reasons. - (Left declined, peer) : declineConcurrent otherCandidates - Right (theRequest, thePeer) -> + Nothing -> + -- If fetching the candidate did not work, this is either + -- because it has been fully requested or because we are + -- already at maximum capacity of the chosen peer. FIXME: + -- Maybe we should find which peer it is and reject this one + -- for a different reason? + declineConcurrent candidates + Just (theRequest, thePeer) -> -- If fetching the candidate _did_ work, then we have a request -- potentially for another peer, so we report this request and -- decline all the peers except for that specific one. @@ -93,6 +99,9 @@ fetchDecisionsBulkSync declineConcurrent = map (first (const (Left (FetchDeclineConcurrencyLimit FetchModeBulkSync 1)))) eqPeerInfo (_, _, _, p1, _) (_, _, _, p2, _) = p1 == p2 +-- FIXME: The 'FetchDeclineConcurrencyLimit' should only be used for +-- 'FetchModeDeadline', and 'FetchModeBulkSync' should have its own reasons. + fetchTheCandidate :: ( HasHeader header, HeaderHash header ~ HeaderHash block @@ -102,7 +111,7 @@ fetchTheCandidate :: MaxSlotNo -> [(AnchoredFragment header, PeerInfo header peer extra)] -> ChainSuffix header -> - FetchDecision ((FetchRequest header), PeerInfo header peer extra) + Maybe ((FetchRequest header), PeerInfo header peer extra) fetchTheCandidate fetchDecisionPolicy fetchedBlocks @@ -113,37 +122,72 @@ fetchTheCandidate -- Filter to keep blocks that have not already been downloaded or that are -- not already in-flight with any peer. fragments <- - filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo chainSuffix - >>= filterNotAlreadyInFlightWithAnyPeer statusInflightInfo - -- For each peer, try to create a request for those fragments. Then take - -- the first one that is successful. - maybeToEither FetchDeclineAlreadyFetched $ - firstRight $ - map - ( \(_, peerInfo@(status, inflight, gsvs, _, _)) -> - -- FIXME: 'fetchRequestDecisions' does not check whether the - -- peer _could_ serve the given blocks, so we need to trim the - -- fragments to only contain blocks that are in the peer's - -- candidate fragment. - (,peerInfo) - <$> fetchRequestDecision - fetchDecisionPolicy - FetchModeBulkSync - nConcurrentFetchPeers - (calculatePeerFetchInFlightLimits gsvs) - inflight - status - (Right fragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. - ) - candidatesAndPeers + rightToMaybe $ + filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo chainSuffix + >>= filterNotAlreadyInFlightWithAnyPeer statusInflightInfo + + -- Trim the fragments to each specific peer's candidate, keeping only + -- blocks that they may actually serve. If they cannot serve any of the + -- blocks, filter them out. + fragmentsAndPeers <- + nonEmpty $ + mapMaybe + ( \(candidate, peerInfo) -> + (,peerInfo) <$> trimFragmentsToCandidate fragments candidate + ) + candidatesAndPeers + + -- For each peer, try to create a request for those fragments. + -- 'fetchRequestDecision' enforces respect of concurrency limits, and + -- 'FetchModeBulkSync' should have a limit of 1. This creates a fairly + -- degenerate situation with two extreme cases of interest: + -- + -- 1. If there is no currently in-flight request, then all the peers are + -- eligible, and all of them will manage to create a request. + -- + -- 2. If there are currently in-flight requests, then they are all with + -- the same peer, and only that peer will manage to create a request. + requestsAndPeers <- + nonEmpty $ + mapMaybe + ( \(fragments', peerInfo@(status, inflight, gsvs, _, _)) -> + (,peerInfo) + <$> ( rightToMaybe $ + fetchRequestDecision + fetchDecisionPolicy + FetchModeBulkSync + nConcurrentFetchPeers + (calculatePeerFetchInFlightLimits gsvs) + inflight + status + (Right fragments') -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. + ) + ) + (NE.toList fragmentsAndPeers) + + -- Return the first successful request. FIXME: Peer ordering respecting a + -- priority list. + pure $ NE.head requestsAndPeers where - statusInflightInfo = map (\(_, (status, inflight, _, _, _)) -> (status, inflight)) candidatesAndPeers + statusInflightInfo = + map (\(_, (status, inflight, _, _, _)) -> (status, inflight)) candidatesAndPeers nConcurrentFetchPeers = -- REVIEW: A bit weird considering that this should be '0' or '1'. fromIntegral $ length $ filter (\(_, inflight) -> peerFetchReqsInFlight inflight > 0) statusInflightInfo - firstRight [] = Nothing - firstRight (Right x : _) = Just x - firstRight (Left _ : xs) = firstRight xs + +-- | Given a candidate and some fragments, keep only the parts of the fragments +-- that are within the candidate. The returned value is @Nothing@ if nothing +-- remains, and a non-empty list of non-empty fragments otherwise. +trimFragmentsToCandidate :: + (HasHeader header) => + [AnchoredFragment header] -> + AnchoredFragment header -> + Maybe [AnchoredFragment header] +trimFragmentsToCandidate fragments candidate = + let trimmedFragments = concatMap (AF.filter (flip AF.withinFragmentBounds candidate . blockPoint)) fragments + in if null trimmedFragments + then Nothing + else Just trimmedFragments -- | A penultimate step of filtering, but this time across peers, rather than -- individually for each peer. If we're following the parallel fetch From 5fffd66e9d59f1440fa77493e506f4c2f0a02cfd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 12 Jun 2024 13:31:27 +0000 Subject: [PATCH 016/136] A note --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 7ba737d6da4..d716158752c 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -128,7 +128,9 @@ fetchTheCandidate -- Trim the fragments to each specific peer's candidate, keeping only -- blocks that they may actually serve. If they cannot serve any of the - -- blocks, filter them out. + -- blocks, filter them out. FIXME: Maybe we should rather have a + -- 'ChainSuffix' for all the peers at this point? Are we not too + -- restrictive by using only their candidate? fragmentsAndPeers <- nonEmpty $ mapMaybe From c5c802b0a85a4ae33e80ac007b6b0b8a469552bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 12 Jun 2024 22:48:41 +0000 Subject: [PATCH 017/136] Allow reading a peer queue in the consensus interface --- .../Network/BlockFetch/ConsensusInterface.hs | 4 +++- .../src/Ouroboros/Network/BlockFetch.hs | 3 ++- .../src/Ouroboros/Network/BlockFetch/Decision.hs | 3 +++ .../src/Ouroboros/Network/BlockFetch/State.hs | 15 ++++++++++----- 4 files changed, 18 insertions(+), 7 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index befe85e015e..1d0458957df 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -151,7 +151,9 @@ data BlockFetchConsensusInterface peer header block m = -- PRECONDITION: Same as 'headerForgeUTCTime'. -- -- WARNING: Same as 'headerForgeUTCTime'. - blockForgeUTCTime :: FromConsensus block -> STM m UTCTime + blockForgeUTCTime :: FromConsensus block -> STM m UTCTime, + + readPeersOrder :: STM m [peer] } diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index 86d0fecea8b..a0fb3f1d705 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -219,5 +219,6 @@ blockFetchLogic decisionTracer clientStateTracer readStatePeerStateVars = readFetchClientsStateVars registry, readStatePeerGSVs = readPeerGSVs registry, readStateFetchMode = readFetchMode, - readStateFetchedMaxSlotNo = readFetchedMaxSlotNo + readStateFetchedMaxSlotNo = readFetchedMaxSlotNo, + readStatePeersOrder = readPeersOrder } diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 67cc5405741..5708e7c4d52 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -45,6 +45,7 @@ fetchDecisions -> AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo + -> [peer] -- ^ Order of the peers for syncing purposes -> [(AnchoredFragment header, PeerInfo header peer extra)] -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] @@ -54,6 +55,7 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo + _peersOrder = fetchDecisionsDeadline fetchDecisionPolicy @@ -67,6 +69,7 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo + _peersOrder = fetchDecisionsBulkSync fetchDecisionPolicy diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 6f072fe035d..0572c1dcec1 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -181,7 +181,8 @@ fetchDecisionsForStateSnapshot fetchStatePeerGSVs, fetchStateFetchedBlocks, fetchStateFetchedMaxSlotNo, - fetchStateFetchMode + fetchStateFetchMode, + fetchStatePeersOrder } = assert ( Map.keysSet fetchStatePeerChains `Set.isSubsetOf` Map.keysSet fetchStatePeerStates) $ @@ -195,6 +196,7 @@ fetchDecisionsForStateSnapshot fetchStateCurrentChain fetchStateFetchedBlocks fetchStateFetchedMaxSlotNo + fetchStatePeersOrder peerChainsAndPeerInfo where peerChainsAndPeerInfo = @@ -255,7 +257,8 @@ data FetchNonTriggerVariables peer header block m = FetchNonTriggerVariables { readStatePeerStateVars :: STM m (Map peer (FetchClientStateVars m header)), readStatePeerGSVs :: STM m (Map peer PeerGSV), readStateFetchMode :: STM m FetchMode, - readStateFetchedMaxSlotNo :: STM m MaxSlotNo + readStateFetchedMaxSlotNo :: STM m MaxSlotNo, + readStatePeersOrder :: STM m [peer] } @@ -298,7 +301,8 @@ data FetchStateSnapshot peer header block m = FetchStateSnapshot { fetchStatePeerGSVs :: Map peer PeerGSV, fetchStateFetchedBlocks :: Point block -> Bool, fetchStateFetchMode :: FetchMode, - fetchStateFetchedMaxSlotNo :: MaxSlotNo + fetchStateFetchedMaxSlotNo :: MaxSlotNo, + fetchStatePeersOrder :: [peer] } readStateVariables :: (MonadSTM m, Eq peer, @@ -335,7 +339,7 @@ readStateVariables FetchTriggerVariables{..} fetchStateFetchedBlocks <- readStateFetchedBlocks fetchStateFetchMode <- readStateFetchMode fetchStateFetchedMaxSlotNo <- readStateFetchedMaxSlotNo - + fetchStatePeersOrder <- readStatePeersOrder -- Construct the overall snapshot of the state let fetchStateSnapshot = @@ -346,7 +350,8 @@ readStateVariables FetchTriggerVariables{..} fetchStatePeerGSVs, fetchStateFetchedBlocks, fetchStateFetchMode, - fetchStateFetchedMaxSlotNo + fetchStateFetchedMaxSlotNo, + fetchStatePeersOrder } return (fetchStateSnapshot, fetchStateFingerprint') From a535930570be2b01e6b83d1229f1e188407763de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 13 Jun 2024 06:17:59 +0000 Subject: [PATCH 018/136] Use peer order in decision --- .../Ouroboros/Network/BlockFetch/Decision.hs | 3 ++- .../Network/BlockFetch/Decision/BulkSync.hs | 21 +++++++++++++++---- 2 files changed, 19 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 5708e7c4d52..5f9bb8becd0 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -69,10 +69,11 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo - _peersOrder + peersOrder = fetchDecisionsBulkSync fetchDecisionPolicy currentChain fetchedBlocks fetchedMaxSlotNo + peersOrder diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index d716158752c..8e246f7baed 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -38,6 +38,7 @@ fetchDecisionsBulkSync :: AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo -> + [peer] -> -- ^ Order of the peers, from most to least preferred [(AnchoredFragment header, PeerInfo header peer extra)] -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisionsBulkSync @@ -45,6 +46,7 @@ fetchDecisionsBulkSync currentChain fetchedBlocks fetchedMaxSlotNo + peersOrder candidatesAndPeers = -- Sort candidates from longest to shortest and filter out all unplausible -- candidates. This gives a list of already-declined candidates and a list @@ -72,6 +74,7 @@ fetchDecisionsBulkSync fetchDecisionPolicy fetchedBlocks fetchedMaxSlotNo + peersOrder candidatesAndPeers candidate of Nothing -> @@ -104,11 +107,13 @@ fetchDecisionsBulkSync fetchTheCandidate :: ( HasHeader header, - HeaderHash header ~ HeaderHash block + HeaderHash header ~ HeaderHash block, + Eq peer ) => FetchDecisionPolicy header -> (Point block -> Bool) -> MaxSlotNo -> + [peer] -> [(AnchoredFragment header, PeerInfo header peer extra)] -> ChainSuffix header -> Maybe ((FetchRequest header), PeerInfo header peer extra) @@ -116,6 +121,7 @@ fetchTheCandidate fetchDecisionPolicy fetchedBlocks fetchedMaxSlotNo + peersOrder candidatesAndPeers chainSuffix = do @@ -167,9 +173,16 @@ fetchTheCandidate ) (NE.toList fragmentsAndPeers) - -- Return the first successful request. FIXME: Peer ordering respecting a - -- priority list. - pure $ NE.head requestsAndPeers + -- Return the first successful request according to the peer order that + -- has been given to us. + requestsAndPeersOrdered <- + nonEmpty + [ (request, peerInfo) + | (request, peerInfo@(_, _, _, peer, _)) <- NE.toList requestsAndPeers, + peer' <- peersOrder, + peer == peer' + ] + pure $ NE.head requestsAndPeersOrdered where statusInflightInfo = map (\(_, (status, inflight, _, _, _)) -> (status, inflight)) candidatesAndPeers From e37410ce7dd7c71cd0cdc73b112a2088bd77ed00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 13 Jun 2024 07:04:31 +0000 Subject: [PATCH 019/136] Keep peers order internal --- .../Network/BlockFetch/ConsensusInterface.hs | 3 -- .../src/Ouroboros/Network/BlockFetch.hs | 37 +++++++++++++++++-- 2 files changed, 33 insertions(+), 7 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index 1d0458957df..63328b6baa5 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -151,9 +151,6 @@ data BlockFetchConsensusInterface peer header block m = -- PRECONDITION: Same as 'headerForgeUTCTime'. -- -- WARNING: Same as 'headerForgeUTCTime'. - blockForgeUTCTime :: FromConsensus block -> STM m UTCTime, - - readPeersOrder :: STM m [peer] } diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index a0fb3f1d705..a48fae7f0ca 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -102,8 +102,11 @@ module Ouroboros.Network.BlockFetch ) where import Data.Hashable (Hashable) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Void +import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked (StrictTVar, newTVarIO, readTVar, writeTVar) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI @@ -174,11 +177,13 @@ blockFetchLogic decisionTracer clientStateTracer setFetchClientContext registry clientStateTracer mkFetchClientPolicy + peersOrderVar <- newTVarIO [] + fetchLogicIterations decisionTracer clientStateTracer fetchDecisionPolicy fetchTriggerVariables - fetchNonTriggerVariables + (fetchNonTriggerVariables peersOrderVar) where mkFetchClientPolicy :: WhetherReceivingTentativeBlocks -> STM m (FetchClientPolicy header block m) mkFetchClientPolicy receivingTentativeBlocks = do @@ -212,13 +217,37 @@ blockFetchLogic decisionTracer clientStateTracer readStatePeerStatus = readFetchClientsStatus registry } - fetchNonTriggerVariables :: FetchNonTriggerVariables addr header block m - fetchNonTriggerVariables = + fetchNonTriggerVariables :: + StrictTVar m [addr] -> + FetchNonTriggerVariables addr header block m + fetchNonTriggerVariables peersOrderVar = FetchNonTriggerVariables { readStateFetchedBlocks = readFetchedBlocks, readStatePeerStateVars = readFetchClientsStateVars registry, readStatePeerGSVs = readPeerGSVs registry, readStateFetchMode = readFetchMode, readStateFetchedMaxSlotNo = readFetchedMaxSlotNo, - readStatePeersOrder = readPeersOrder + readStatePeersOrder = readPeersOrder peersOrderVar readCandidateChains } + +-- | Read the current peers order from the TVar, update it according to the +-- current peers, and return the updated order. +readPeersOrder :: + ( MonadSTM m, + Eq addr + ) => + -- | The TVar containing the current order of peers + StrictTVar m [addr] -> + -- | An STM action to read all the current + -- peers. This can for instance be + -- 'readCandidateChains' + STM m (Map addr whatever) -> + STM m [addr] +readPeersOrder peersOrderVar readPeers = do + peers <- Map.keys <$> readPeers + peersOrder <- readTVar peersOrderVar + let peersOrder' = + filter (`elem` peers) peersOrder + ++ filter (`notElem` peersOrder) peers + writeTVar peersOrderVar peersOrder' + pure peersOrder' From 3ac66dda0e7f1140ce3ddf3412c75e340969678c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 13 Jun 2024 07:04:43 +0000 Subject: [PATCH 020/136] Add action to demote the dynamo --- .../src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index 63328b6baa5..ba1ba0e0e5f 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -151,6 +151,12 @@ data BlockFetchConsensusInterface peer header block m = -- PRECONDITION: Same as 'headerForgeUTCTime'. -- -- WARNING: Same as 'headerForgeUTCTime'. + blockForgeUTCTime :: FromConsensus block -> STM m UTCTime, + + -- | Action to inform CSJ that its dynamo has not been performing + -- adequately with respect to BlockFetch, and that it should be demoted. + -- Can be set to @pure ()@ in all other scenarios. + demoteCSJDynamo :: m () } From 9ffe465d87f116be39c2758c9f94bfd585e80c25 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 13 Jun 2024 17:20:42 +0200 Subject: [PATCH 021/136] Keep more granular decisions for each peer --- .../Network/BlockFetch/Decision/BulkSync.hs | 264 +++++++++--------- 1 file changed, 139 insertions(+), 125 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 8e246f7baed..1e092c0034b 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -8,8 +8,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync ) where -import Cardano.Prelude (rightToMaybe, mapMaybe) -import Data.Bifunctor (first) +import Data.Bifunctor (first, Bifunctor (..)) import Data.List (foldl', sortOn) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE @@ -38,73 +37,75 @@ fetchDecisionsBulkSync :: AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo -> - [peer] -> -- ^ Order of the peers, from most to least preferred + -- | Order of the peers, from most to least preferred + [peer] -> [(AnchoredFragment header, PeerInfo header peer extra)] -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisionsBulkSync - fetchDecisionPolicy@FetchDecisionPolicy {plausibleCandidateChain} + fetchDecisionPolicy currentChain fetchedBlocks fetchedMaxSlotNo - peersOrder - candidatesAndPeers = - -- Sort candidates from longest to shortest and filter out all unplausible - -- candidates. This gives a list of already-declined candidates and a list - -- of plausible candidates. - let (declinedCandidates, candidates) = - partitionEithersFirst - -- Select the suffix up to the intersection with the current chain. - . selectForkSuffixes - currentChain - -- Filter to keep chains the consensus layer tells us are plausible. - . filterPlausibleCandidates - plausibleCandidateChain - currentChain - -- Sort the candidates by descending block number of their heads, that is - -- consider longest fragments first. - . sortOn (Down . headBlockNo . fst) - $ candidatesAndPeers - in -- If there are no candidates remaining, we are done. Otherwise, pick the - -- first one and try to fetch it. Decline all the others. - map (first Left) declinedCandidates - ++ case candidates of - [] -> [] - ((candidate, _) : _) -> - case fetchTheCandidate - fetchDecisionPolicy - fetchedBlocks - fetchedMaxSlotNo - peersOrder - candidatesAndPeers - candidate of - Nothing -> - -- If fetching the candidate did not work, this is either - -- because it has been fully requested or because we are - -- already at maximum capacity of the chosen peer. FIXME: - -- Maybe we should find which peer it is and reject this one - -- for a different reason? - declineConcurrent candidates - Just (theRequest, thePeer) -> - -- If fetching the candidate _did_ work, then we have a request - -- potentially for another peer, so we report this request and - -- decline all the peers except for that specific one. - (Right theRequest, thePeer) - : filter (not . eqPeerInfo thePeer . snd) (declineConcurrent candidates) - where - partitionEithersFirst :: [(Either a b, c)] -> ([(a, c)], [(b, c)]) - partitionEithersFirst = - foldr - ( \(e, c) (as, bs) -> case e of - Left a -> ((a, c) : as, bs) - Right b -> (as, (b, c) : bs) - ) - ([], []) - declineConcurrent = map (first (const (Left (FetchDeclineConcurrencyLimit FetchModeBulkSync 1)))) - eqPeerInfo (_, _, _, p1, _) (_, _, _, p2, _) = p1 == p2 + peersOrder = + -- Select the candidate to sync from, then try to fetch it from the peers + -- that are still in the race to serve it, which gives us one peer to fetch + -- from and all the others to decline. + uncurry (++) + . ( second $ + maybe + [] + ( uncurry $ + fetchTheCandidate + fetchDecisionPolicy + fetchedBlocks + fetchedMaxSlotNo + peersOrder + ) + ) + . ( selectTheCandidate + fetchDecisionPolicy + currentChain + ) -- FIXME: The 'FetchDeclineConcurrencyLimit' should only be used for -- 'FetchModeDeadline', and 'FetchModeBulkSync' should have its own reasons. +selectTheCandidate :: + ( HasHeader header + ) => + FetchDecisionPolicy header -> + -- | The current chain. + AnchoredFragment header -> + -- | The candidate fragments and their associated peers. + [(AnchoredFragment header, peerInfo)] -> + -- | The pair of: (a) a list of peers that we have decided are not right, eg. + -- because they presented us with a chain forking too deep, and (b) the + -- selected candidate that we choose to sync from and a list of peers that are + -- still in the race to serve that candidate. + ( [(FetchDecision any, peerInfo)], + Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)]) + ) +selectTheCandidate + FetchDecisionPolicy {plausibleCandidateChain} + currentChain = + separateDeclinedAndStillInRace + -- Select the suffix up to the intersection with the current chain. This can + -- eliminate candidates that fork too deep. + . selectForkSuffixes currentChain + -- Filter to keep chains the consensus layer tells us are plausible. + . filterPlausibleCandidates plausibleCandidateChain currentChain + -- Sort the candidates by descending block number of their heads, that is + -- consider longest fragments first. + . sortOn (Down . headBlockNo . fst) + where + -- Very ad-hoc helper. + separateDeclinedAndStillInRace :: [(Either a b, c)] -> ([(Either a any, c)], Maybe (b, [(b, c)])) + separateDeclinedAndStillInRace xs = + let (declined, inRace) = partitionEithersFirst xs + in ( map (first Left) declined, + ((,inRace) . fst . NE.head) <$> nonEmpty inRace + ) + fetchTheCandidate :: ( HasHeader header, HeaderHash header ~ HeaderHash block, @@ -114,95 +115,98 @@ fetchTheCandidate :: (Point block -> Bool) -> MaxSlotNo -> [peer] -> - [(AnchoredFragment header, PeerInfo header peer extra)] -> ChainSuffix header -> - Maybe ((FetchRequest header), PeerInfo header peer extra) + [(ChainSuffix header, PeerInfo header peer extra)] -> + [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchTheCandidate fetchDecisionPolicy fetchedBlocks fetchedMaxSlotNo peersOrder - candidatesAndPeers - chainSuffix = - do - -- Filter to keep blocks that have not already been downloaded or that are - -- not already in-flight with any peer. - fragments <- - rightToMaybe $ + chainSuffix + candidates = + let -- Keep blocks that have not already been downloaded or that are not + -- already in-flight with any peer. This returns a 'FetchDecision'. + fragments = filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo chainSuffix >>= filterNotAlreadyInFlightWithAnyPeer statusInflightInfo - -- Trim the fragments to each specific peer's candidate, keeping only - -- blocks that they may actually serve. If they cannot serve any of the - -- blocks, filter them out. FIXME: Maybe we should rather have a - -- 'ChainSuffix' for all the peers at this point? Are we not too - -- restrictive by using only their candidate? - fragmentsAndPeers <- - nonEmpty $ - mapMaybe - ( \(candidate, peerInfo) -> - (,peerInfo) <$> trimFragmentsToCandidate fragments candidate - ) - candidatesAndPeers + -- For each peer with its candidate, try to create a request for those + -- fragments. We are not yet deciding which peer to fetch from. + requests = + map + ( \(candidate, peerInfo@(status, inflight, gsvs, _, _)) -> + (,peerInfo) $ do + -- Trim the fragments to each specific peer's candidate, keeping only + -- blocks that they may actually serve. If they cannot serve any of the + -- blocks, filter them out. + trimmedFragments <- trimFragmentsToCandidate candidate =<< fragments - -- For each peer, try to create a request for those fragments. - -- 'fetchRequestDecision' enforces respect of concurrency limits, and - -- 'FetchModeBulkSync' should have a limit of 1. This creates a fairly - -- degenerate situation with two extreme cases of interest: - -- - -- 1. If there is no currently in-flight request, then all the peers are - -- eligible, and all of them will manage to create a request. - -- - -- 2. If there are currently in-flight requests, then they are all with - -- the same peer, and only that peer will manage to create a request. - requestsAndPeers <- - nonEmpty $ - mapMaybe - ( \(fragments', peerInfo@(status, inflight, gsvs, _, _)) -> - (,peerInfo) - <$> ( rightToMaybe $ - fetchRequestDecision - fetchDecisionPolicy - FetchModeBulkSync - nConcurrentFetchPeers - (calculatePeerFetchInFlightLimits gsvs) - inflight - status - (Right fragments') -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. - ) + -- For each peer, try to create a request for those fragments. + -- 'fetchRequestDecision' enforces respect of concurrency limits, and + -- 'FetchModeBulkSync' should have a limit of 1. This creates a fairly + -- degenerate situation with two extreme cases of interest: + -- + -- 1. If there is no currently in-flight request, then all the peers are + -- eligible, and all of them will manage to create a request. + -- + -- 2. If there are currently in-flight requests, then they are all with + -- the same peer, and only that peer will manage to create a request. + request <- + fetchRequestDecision + fetchDecisionPolicy + FetchModeBulkSync + nConcurrentFetchPeers + (calculatePeerFetchInFlightLimits gsvs) + inflight + status + (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. + pure request ) - (NE.toList fragmentsAndPeers) + candidates - -- Return the first successful request according to the peer order that - -- has been given to us. - requestsAndPeersOrdered <- - nonEmpty - [ (request, peerInfo) - | (request, peerInfo@(_, _, _, peer, _)) <- NE.toList requestsAndPeers, - peer' <- peersOrder, - peer == peer' - ] - pure $ NE.head requestsAndPeersOrdered + -- Order the requests according to the peer order that we have been + -- given, then separate between declined and accepted requests. + (declinedRequests, requestsOrdered) = + partitionEithersFirst + [ (request, peerInfo) + | (request, peerInfo@(_, _, _, peer, _)) <- requests, + peer' <- peersOrder, + peer == peer' + ] + in -- Return the first peer in that order, and decline all the ones that were + -- not already declined. + case requestsOrdered of + [] -> [] + (theRequest, thePeer) : otherRequests -> + (Right theRequest, thePeer) + : map (first (const (Left (FetchDeclineConcurrencyLimit FetchModeBulkSync 1)))) otherRequests + ++ map (first Left) declinedRequests where statusInflightInfo = - map (\(_, (status, inflight, _, _, _)) -> (status, inflight)) candidatesAndPeers + map (\(_, (status, inflight, _, _, _)) -> (status, inflight)) candidates nConcurrentFetchPeers = -- REVIEW: A bit weird considering that this should be '0' or '1'. fromIntegral $ length $ filter (\(_, inflight) -> peerFetchReqsInFlight inflight > 0) statusInflightInfo -- | Given a candidate and some fragments, keep only the parts of the fragments --- that are within the candidate. The returned value is @Nothing@ if nothing --- remains, and a non-empty list of non-empty fragments otherwise. +-- that are within the candidate. Decline if nothing remains, and return a +-- non-empty list of non-empty fragments otherwise. trimFragmentsToCandidate :: (HasHeader header) => + ChainSuffix header -> [AnchoredFragment header] -> - AnchoredFragment header -> - Maybe [AnchoredFragment header] -trimFragmentsToCandidate fragments candidate = - let trimmedFragments = concatMap (AF.filter (flip AF.withinFragmentBounds candidate . blockPoint)) fragments + FetchDecision [AnchoredFragment header] +trimFragmentsToCandidate candidate fragments = + let trimmedFragments = + -- FIXME: This can most definitely be improved considering that the + -- property to be in `candidate` is monotonic. + concatMap + (AF.filter (flip AF.withinFragmentBounds (getChainSuffix candidate) . blockPoint)) + fragments in if null trimmedFragments - then Nothing - else Just trimmedFragments + then Left FetchDeclineAlreadyFetched + else Right trimmedFragments -- | A penultimate step of filtering, but this time across peers, rather than -- individually for each peer. If we're following the parallel fetch @@ -235,3 +239,13 @@ filterNotAlreadyInFlightWithAnyPeer statusInflightInfos chainfragments = ] -- The highest slot number that is or has been in flight for any peer. maxSlotNoInFlight = foldl' max NoMaxSlotNo (map (peerFetchMaxSlotNo . snd) statusInflightInfos) + +-- | Partition eithers on the first component of the pair. +partitionEithersFirst :: [(Either a b, c)] -> ([(a, c)], [(b, c)]) +partitionEithersFirst = + foldr + ( \(e, c) (as, bs) -> case e of + Left a -> ((a, c) : as, bs) + Right b -> (as, (b, c) : bs) + ) + ([], []) From db3f862fc2bf2098c7359f8194ca777c0b671655 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 14 Jun 2024 11:14:01 +0200 Subject: [PATCH 022/136] Documentation --- .../Network/BlockFetch/Decision/BulkSync.hs | 26 ++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 1e092c0034b..0b379501983 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -28,6 +28,8 @@ import Ouroboros.Network.BlockFetch.Decision.Common -- arises, we should move the interesting piece of code to 'Decision.Common'. -- This is to be done on demand. +-- | Given a list of candidate fragments and their associated peers, choose what +-- to sync from who in the bulk sync mode. fetchDecisionsBulkSync :: ( HasHeader header, HeaderHash header ~ HeaderHash block, @@ -37,10 +39,13 @@ fetchDecisionsBulkSync :: AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo -> - -- | Order of the peers, from most to least preferred + -- | Order of the peers, from most to least preferred. [peer] -> + -- | Association list of the candidate fragments and their associated peers. [(AnchoredFragment header, PeerInfo header peer extra)] -> + -- | Association list of the requests and their associated peers. [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] + fetchDecisionsBulkSync fetchDecisionPolicy currentChain @@ -70,6 +75,10 @@ fetchDecisionsBulkSync -- FIXME: The 'FetchDeclineConcurrencyLimit' should only be used for -- 'FetchModeDeadline', and 'FetchModeBulkSync' should have its own reasons. +-- | Given a list of candidate fragments and their associated peers, select the +-- candidate to sync from. Return this fragment, the list of peers that are +-- still in race to serve it, and the list of peers that are already being +-- declined. selectTheCandidate :: ( HasHeader header ) => @@ -85,6 +94,7 @@ selectTheCandidate :: ( [(FetchDecision any, peerInfo)], Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)]) ) + selectTheCandidate FetchDecisionPolicy {plausibleCandidateChain} currentChain = @@ -106,6 +116,12 @@ selectTheCandidate ((,inRace) . fst . NE.head) <$> nonEmpty inRace ) +-- | Given a candidate to sync from and a list of peers in race to serve that, +-- choose which peer to sync from and decline the others. +-- +-- PRECONDITION: The set of peers must be included in the peer order queue. +-- +-- POSTCONDITION: The returned list contains at most one @Right@ element. fetchTheCandidate :: ( HasHeader header, HeaderHash header ~ HeaderHash block, @@ -114,10 +130,18 @@ fetchTheCandidate :: FetchDecisionPolicy header -> (Point block -> Bool) -> MaxSlotNo -> + -- | Order of the peers, from most to least preferred. [peer] -> + -- | The candidate fragment that we have selected to sync from, as suffix of + -- the immutable tip. ChainSuffix header -> + -- | Association list of candidate fragments (as suffixes of the immutable + -- tip) and their associated peers. [(ChainSuffix header, PeerInfo header peer extra)] -> + -- | Association list of the requests and the peers that they are associated + -- with. The requests can only be declined. [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] + fetchTheCandidate fetchDecisionPolicy fetchedBlocks From 54e6cbc7e491d5938d723281518ec1ef006e47a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 14 Jun 2024 15:55:25 +0200 Subject: [PATCH 023/136] Some minor improvements --- .../Network/BlockFetch/ConsensusInterface.hs | 9 +++-- .../src/Ouroboros/Network/BlockFetch.hs | 37 +++++++++++++++---- .../src/Ouroboros/Network/BlockFetch/State.hs | 4 +- 3 files changed, 38 insertions(+), 12 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index ba1ba0e0e5f..5958f8fa467 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -153,10 +153,11 @@ data BlockFetchConsensusInterface peer header block m = -- WARNING: Same as 'headerForgeUTCTime'. blockForgeUTCTime :: FromConsensus block -> STM m UTCTime, - -- | Action to inform CSJ that its dynamo has not been performing - -- adequately with respect to BlockFetch, and that it should be demoted. - -- Can be set to @pure ()@ in all other scenarios. - demoteCSJDynamo :: m () + -- | Action to inform CSJ that the given peer has not been performing + -- adequately with respect to BlockFetch, and that it should be demoted + -- from the dynamo role. Can be set to @const (pure ())@ in all other + -- scenarios. + demoteCSJDynamo :: peer -> m () } diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index a48fae7f0ca..d1dec25e589 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -184,6 +184,7 @@ blockFetchLogic decisionTracer clientStateTracer fetchDecisionPolicy fetchTriggerVariables (fetchNonTriggerVariables peersOrderVar) + (reportBadPeer demoteCSJDynamo peersOrderVar) where mkFetchClientPolicy :: WhetherReceivingTentativeBlocks -> STM m (FetchClientPolicy header block m) mkFetchClientPolicy receivingTentativeBlocks = do @@ -236,18 +237,40 @@ readPeersOrder :: ( MonadSTM m, Eq addr ) => - -- | The TVar containing the current order of peers + -- | The TVar containing the current order of peers. StrictTVar m [addr] -> - -- | An STM action to read all the current - -- peers. This can for instance be - -- 'readCandidateChains' + -- | An STM action to read all the current peers. This can for instance be + -- 'readCandidateChains'. STM m (Map addr whatever) -> STM m [addr] readPeersOrder peersOrderVar readPeers = do - peers <- Map.keys <$> readPeers peersOrder <- readTVar peersOrderVar + currentPeers <- Map.keys <$> readPeers let peersOrder' = - filter (`elem` peers) peersOrder - ++ filter (`notElem` peersOrder) peers + filter (`elem` currentPeers) peersOrder + ++ filter (`notElem` peersOrder) currentPeers writeTVar peersOrderVar peersOrder' pure peersOrder' + +-- | Report a peer as a bad peer. This pushes the peer to the end of the peers +-- order and demotes it from the dynamo role in ChainSync Jumping (CSJ) in the +-- consensus layer. +reportBadPeer :: + ( MonadSTM m, + Eq peer + ) => + -- | An STM action to demote a peer from the dynamo role in ChainSync Jumping + -- (CSJ) in the consensus layer. + (peer -> m ()) -> + -- | The TVar containing the current order of peers. + StrictTVar m [peer] -> + -- | The peer that we know is a bad peer (e.g. because it has not respected + -- our syncing BlockFetch timeouts). + peer -> + m () +reportBadPeer demoteCSJDynamo peersOrderVar peer = do + atomically $ do + peersOrder <- readTVar peersOrderVar + let peersOrder' = filter (/= peer) peersOrder ++ [peer] + writeTVar peersOrderVar peersOrder' + demoteCSJDynamo peer diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 0572c1dcec1..73b4bb3531a 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -58,11 +58,13 @@ fetchLogicIterations -> FetchDecisionPolicy header -> FetchTriggerVariables peer header m -> FetchNonTriggerVariables peer header block m + -> (peer -> m ()) -- ^ Report a peer as bad with respect to BlockFetch. -> m Void fetchLogicIterations decisionTracer clientStateTracer fetchDecisionPolicy fetchTriggerVariables - fetchNonTriggerVariables = + fetchNonTriggerVariables + _reportBadPeer = iterateForever initialFetchStateFingerprint $ \stateFingerprint -> do From 32bfd08aab8cfbe01c3fbe1e7ab8947267702835 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 14 Jun 2024 17:53:38 +0200 Subject: [PATCH 024/136] Rewrite with new logic as discussed in the sync --- .../Network/BlockFetch/Decision/BulkSync.hs | 358 +++++++++++------- .../Network/BlockFetch/Decision/Common.hs | 1 + 2 files changed, 219 insertions(+), 140 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 0b379501983..308dd45deb3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -8,18 +8,18 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync ) where +import Control.Monad.Writer (Writer, runWriter, MonadWriter (writer)) import Data.Bifunctor (first, Bifunctor (..)) -import Data.List (foldl', sortOn) +import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) import Data.Ord (Down(Down)) -import qualified Data.Set as Set import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), - PeerFetchInFlight (..), PeerFetchStatus (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) @@ -28,6 +28,17 @@ import Ouroboros.Network.BlockFetch.Decision.Common -- arises, we should move the interesting piece of code to 'Decision.Common'. -- This is to be done on demand. +type WithDeclined peer = MaybeT (Writer [(FetchDecline, peer)]) + +withDeclined :: (Maybe a, [(FetchDecline, peer)]) -> WithDeclined peer a +withDeclined = MaybeT . writer + +runWithDeclined :: WithDeclined peer a -> (Maybe a, [(FetchDecline, peer)]) +runWithDeclined = runWriter . runMaybeT + +combineWithDeclined :: WithDeclined peer [(FetchDecision a, peer)] -> [(FetchDecision a, peer)] +combineWithDeclined = uncurry (++) . bimap (fromMaybe []) (map (first Left)) . runWithDeclined + -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. fetchDecisionsBulkSync :: @@ -45,32 +56,48 @@ fetchDecisionsBulkSync :: [(AnchoredFragment header, PeerInfo header peer extra)] -> -- | Association list of the requests and their associated peers. [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] - fetchDecisionsBulkSync fetchDecisionPolicy currentChain fetchedBlocks fetchedMaxSlotNo - peersOrder = - -- Select the candidate to sync from, then try to fetch it from the peers - -- that are still in the race to serve it, which gives us one peer to fetch - -- from and all the others to decline. - uncurry (++) - . ( second $ - maybe - [] - ( uncurry $ - fetchTheCandidate - fetchDecisionPolicy - fetchedBlocks - fetchedMaxSlotNo - peersOrder - ) - ) - . ( selectTheCandidate + peersOrder + candidatesAndPeers = combineWithDeclined $ do + -- Step 1: Select the candidate to sync from. This already eliminates + -- peers that have an implausible candidate. + (theCandidate, candidatesAndPeers') <- + -- FIXME: make 'selectTheCandidate' return a 'WithDeclined'? + withDeclined $ + selectTheCandidate + fetchDecisionPolicy + currentChain + candidatesAndPeers + + -- Step 2: Select the peer to sync from. This eliminates peers that + -- cannot serve a reasonable batch of the candidate, then chooses the + -- peer to sync from, then again declines the others. + thePeer <- + -- FIXME: make 'selectThePeer' return a 'WithDeclined'? + withDeclined $ + selectThePeer + fetchDecisionPolicy + fetchedBlocks + fetchedMaxSlotNo + peersOrder + theCandidate + candidatesAndPeers' + + -- Step 3: Fetch the candidate from the selected peer, potentially + -- declining it (eg. if the peer is already too busy). + let decision = + fetchTheCandidate fetchDecisionPolicy - currentChain - ) + fetchedBlocks + fetchedMaxSlotNo + theCandidate + thePeer + + pure [decision] -- FIXME: The 'FetchDeclineConcurrencyLimit' should only be used for -- 'FetchModeDeadline', and 'FetchModeBulkSync' should have its own reasons. @@ -91,10 +118,9 @@ selectTheCandidate :: -- because they presented us with a chain forking too deep, and (b) the -- selected candidate that we choose to sync from and a list of peers that are -- still in the race to serve that candidate. - ( [(FetchDecision any, peerInfo)], - Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)]) + ( Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)]), + [(FetchDecline, peerInfo)] ) - selectTheCandidate FetchDecisionPolicy {plausibleCandidateChain} currentChain = @@ -109,20 +135,17 @@ selectTheCandidate . sortOn (Down . headBlockNo . fst) where -- Very ad-hoc helper. - separateDeclinedAndStillInRace :: [(Either a b, c)] -> ([(Either a any, c)], Maybe (b, [(b, c)])) + separateDeclinedAndStillInRace :: [(Either a b, c)] -> (Maybe (b, [(b, c)]), [(a, c)]) separateDeclinedAndStillInRace xs = let (declined, inRace) = partitionEithersFirst xs - in ( map (first Left) declined, - ((,inRace) . fst . NE.head) <$> nonEmpty inRace + in ( ((,inRace) . fst . NE.head) <$> nonEmpty inRace, + declined ) --- | Given a candidate to sync from and a list of peers in race to serve that, --- choose which peer to sync from and decline the others. +-- | -- -- PRECONDITION: The set of peers must be included in the peer order queue. --- --- POSTCONDITION: The returned list contains at most one @Right@ element. -fetchTheCandidate :: +selectThePeer :: ( HasHeader header, HeaderHash header ~ HeaderHash block, Eq peer @@ -138,131 +161,134 @@ fetchTheCandidate :: -- | Association list of candidate fragments (as suffixes of the immutable -- tip) and their associated peers. [(ChainSuffix header, PeerInfo header peer extra)] -> - -- | Association list of the requests and the peers that they are associated - -- with. The requests can only be declined. - [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] - -fetchTheCandidate - fetchDecisionPolicy + ( Maybe (ChainSuffix header, PeerInfo header peer extra), + [(FetchDecline, PeerInfo header peer extra)] + ) +selectThePeer + FetchDecisionPolicy {blockFetchSize} fetchedBlocks fetchedMaxSlotNo peersOrder - chainSuffix + theCandidate candidates = - let -- Keep blocks that have not already been downloaded or that are not - -- already in-flight with any peer. This returns a 'FetchDecision'. + let -- Filter out from the chosen candidate fragment the blocks that have + -- already been downloaded, but keep the blocks that have a request in + -- flight. fragments = - filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo chainSuffix - >>= filterNotAlreadyInFlightWithAnyPeer statusInflightInfo + snd + <$> filterNotAlreadyFetched + fetchedBlocks + fetchedMaxSlotNo + theCandidate - -- For each peer with its candidate, try to create a request for those - -- fragments. We are not yet deciding which peer to fetch from. - requests = - map - ( \(candidate, peerInfo@(status, inflight, gsvs, _, _)) -> - (,peerInfo) $ do - -- Trim the fragments to each specific peer's candidate, keeping only - -- blocks that they may actually serve. If they cannot serve any of the - -- blocks, filter them out. - trimmedFragments <- trimFragmentsToCandidate candidate =<< fragments + -- Create a fetch request for the blocks in question The request is made + -- to fit in 1MB but ignores everything else. It is gross in that sense. + -- It will only be used to choose the peer to fetch from, but we will + -- later craft a more refined request for that peer. + grossRequest = + selectBlocksUpToLimits + blockFetchSize + 0 -- number of request in flight + maxBound -- maximum number of requests in flight + 0 -- bytes in flight + (1024 * 1024) -- maximum bytes in flight; one megabyte + <$> fragments - -- For each peer, try to create a request for those fragments. - -- 'fetchRequestDecision' enforces respect of concurrency limits, and - -- 'FetchModeBulkSync' should have a limit of 1. This creates a fairly - -- degenerate situation with two extreme cases of interest: - -- - -- 1. If there is no currently in-flight request, then all the peers are - -- eligible, and all of them will manage to create a request. - -- - -- 2. If there are currently in-flight requests, then they are all with - -- the same peer, and only that peer will manage to create a request. - request <- - fetchRequestDecision - fetchDecisionPolicy - FetchModeBulkSync - nConcurrentFetchPeers - (calculatePeerFetchInFlightLimits gsvs) - inflight - status - (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. - pure request + -- For each peer, check whether its candidate contains the gross request + -- in its entirety, otherwise decline it. + peers = + map + ( first $ \candidate -> do + checkRequestInCandidate candidate =<< grossRequest + pure candidate ) candidates - -- Order the requests according to the peer order that we have been - -- given, then separate between declined and accepted requests. - (declinedRequests, requestsOrdered) = + -- Order the peers according to the peer order that we have been given, + -- then separate between declined peers and the others. + (declinedPeers, peersOrdered) = partitionEithersFirst - [ (request, peerInfo) - | (request, peerInfo@(_, _, _, peer, _)) <- requests, + [ (decision, peerInfo) + | (decision, peerInfo@(_, _, _, peer, _)) <- peers, peer' <- peersOrder, peer == peer' ] in -- Return the first peer in that order, and decline all the ones that were -- not already declined. - case requestsOrdered of - [] -> [] - (theRequest, thePeer) : otherRequests -> - (Right theRequest, thePeer) - : map (first (const (Left (FetchDeclineConcurrencyLimit FetchModeBulkSync 1)))) otherRequests - ++ map (first Left) declinedRequests + case peersOrdered of + [] -> + ( Nothing, + declinedPeers + ) + (thePeerCandidate, thePeer) : otherPeers -> + ( Just (thePeerCandidate, thePeer), + declinedPeers + ++ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers + ) where - statusInflightInfo = - map (\(_, (status, inflight, _, _, _)) -> (status, inflight)) candidates - nConcurrentFetchPeers = - -- REVIEW: A bit weird considering that this should be '0' or '1'. - fromIntegral $ length $ filter (\(_, inflight) -> peerFetchReqsInFlight inflight > 0) statusInflightInfo + checkRequestInCandidate candidate request = + if all isSubfragmentOfCandidate $ fetchRequestFragments request + then pure () + else Left $ FetchDeclineAlreadyFetched -- FIXME: A custom decline reason for this? + where + isSubfragmentOfCandidate fragment = + AF.withinFragmentBounds (AF.anchorPoint fragment) (getChainSuffix candidate) + && AF.withinFragmentBounds (AF.headPoint fragment) (getChainSuffix candidate) --- | Given a candidate and some fragments, keep only the parts of the fragments --- that are within the candidate. Decline if nothing remains, and return a --- non-empty list of non-empty fragments otherwise. -trimFragmentsToCandidate :: - (HasHeader header) => +-- | Given a candidate and a peer to sync from, create a request for that +-- specific peer. We might take the 'FetchDecision' to decline the request, but +-- only for “good” reasons, eg. if the peer is already too busy. +fetchTheCandidate :: + ( HasHeader header, + HeaderHash header ~ HeaderHash block + ) => + FetchDecisionPolicy header -> + (Point block -> Bool) -> + MaxSlotNo -> + -- | The candidate fragment that we have selected to sync from, as suffix of + -- the immutable tip. ChainSuffix header -> - [AnchoredFragment header] -> - FetchDecision [AnchoredFragment header] -trimFragmentsToCandidate candidate fragments = - let trimmedFragments = - -- FIXME: This can most definitely be improved considering that the - -- property to be in `candidate` is monotonic. - concatMap - (AF.filter (flip AF.withinFragmentBounds (getChainSuffix candidate) . blockPoint)) - fragments - in if null trimmedFragments - then Left FetchDeclineAlreadyFetched - else Right trimmedFragments + -- | The peer that we have selected to sync from, with its candidate fragment + -- as suffix of the immutable tip. + (ChainSuffix header, PeerInfo header peer extra) -> + (FetchDecision (FetchRequest header), PeerInfo header peer extra) +fetchTheCandidate + fetchDecisionPolicy + fetchedBlocks + fetchedMaxSlotNo + theCandidate + (thePeerCandidate, thePeer@(status, inflight, gsvs, _, _)) = + (,thePeer) $ do + -- Keep blocks that have not already been downloaded or that are not + -- already in-flight with this peer. + fragments <- + filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate + >>= filterNotAlreadyInFlightWithPeer inflight --- | A penultimate step of filtering, but this time across peers, rather than --- individually for each peer. If we're following the parallel fetch --- mode then we filter out blocks that are already in-flight with other --- peers. --- --- Note that this does /not/ cover blocks that are proposed to be fetched in --- this round of decisions. That step is covered in 'fetchRequestDecisions'. -filterNotAlreadyInFlightWithAnyPeer :: - (HasHeader header) => - [(PeerFetchStatus header, PeerFetchInFlight header)] -> - CandidateFragments header -> - FetchDecision [AnchoredFragment header] -filterNotAlreadyInFlightWithAnyPeer statusInflightInfos chainfragments = - if null fragments - then Left FetchDeclineInFlightOtherPeer - else Right fragments - where - fragments = concatMap (filterWithMaxSlotNo notAlreadyInFlight maxSlotNoInFlight) $ snd chainfragments - notAlreadyInFlight b = blockPoint b `Set.notMember` blocksInFlightWithOtherPeers - -- All the blocks that are already in-flight with all peers - blocksInFlightWithOtherPeers = - Set.unions - [ case status of - PeerFetchStatusShutdown -> Set.empty - PeerFetchStatusStarting -> Set.empty - PeerFetchStatusAberrant -> Set.empty - _other -> peerFetchBlocksInFlight inflight - | (status, inflight) <- statusInflightInfos - ] - -- The highest slot number that is or has been in flight for any peer. - maxSlotNoInFlight = foldl' max NoMaxSlotNo (map (peerFetchMaxSlotNo . snd) statusInflightInfos) + -- Trim the fragments to the peer's candidate, keeping only blocks that + -- they may actually serve. + trimmedFragments <- trimFragmentsToCandidate thePeerCandidate (snd fragments) + + -- Try to create a request for those fragments. + fetchRequestDecision + fetchDecisionPolicy + FetchModeBulkSync + 0 -- bypass all concurrency limits. REVIEW: is this really what we want? + (calculatePeerFetchInFlightLimits gsvs) + inflight + status + (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. + where + trimFragmentsToCandidate candidate fragments = + let trimmedFragments = + -- FIXME: This can most definitely be improved considering that the + -- property to be in `candidate` is monotonic. + concatMap + (AF.filter (flip AF.withinFragmentBounds (getChainSuffix candidate) . blockPoint)) + fragments + in if null trimmedFragments + then Left FetchDeclineAlreadyFetched + else Right trimmedFragments -- | Partition eithers on the first component of the pair. partitionEithersFirst :: [(Either a b, c)] -> ([(a, c)], [(b, c)]) @@ -273,3 +299,55 @@ partitionEithersFirst = Right b -> (as, (b, c) : bs) ) ([], []) + +-------------------------------------------------------------------------------- +-- The following is copied from package `transformers` 0.6.1.1. + +-- | The parameterizable maybe monad, obtained by composing an arbitrary +-- monad with the 'Maybe' monad. +-- +-- Computations are actions that may produce a value or exit. +-- +-- The 'return' function yields a computation that produces that +-- value, while @>>=@ sequences two subcomputations, exiting if either +-- computation does. +newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } + +-- | Transform the computation inside a @MaybeT@. +-- +-- * @'runMaybeT' ('mapMaybeT' f m) = f ('runMaybeT' m)@ +mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b +mapMaybeT f = MaybeT . f . runMaybeT +{-# INLINE mapMaybeT #-} + +instance (Functor m) => Functor (MaybeT m) where + fmap f = mapMaybeT (fmap (fmap f)) + {-# INLINE fmap #-} + +instance (Functor m, Monad m) => Applicative (MaybeT m) where + pure = MaybeT . return . Just + {-# INLINE pure #-} + mf <*> mx = MaybeT $ do + mb_f <- runMaybeT mf + case mb_f of + Nothing -> return Nothing + Just f -> do + mb_x <- runMaybeT mx + case mb_x of + Nothing -> return Nothing + Just x -> return (Just (f x)) + {-# INLINE (<*>) #-} + m *> k = m >>= \_ -> k + {-# INLINE (*>) #-} + +instance (Monad m) => Monad (MaybeT m) where + -- return = MaybeT . return . Just + -- {-# INLINE return #-} + x >>= f = MaybeT $ do + v <- runMaybeT x + case v of + Nothing -> return Nothing + Just y -> runMaybeT (f y) + {-# INLINE (>>=) #-} + -- fail _ = MaybeT (return Nothing) + -- {-# INLINE fail #-} diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index 3ea01ce2442..6faa09c9f4d 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -21,6 +21,7 @@ module Ouroboros.Network.BlockFetch.Decision.Common ( , filterNotAlreadyInFlightWithPeer' , filterNotAlreadyFetched' , fetchRequestDecision + , selectBlocksUpToLimits ) where import GHC.Stack (HasCallStack) From 082fe818fcc54471514a168c3badd070856d32b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 14 Jun 2024 18:11:30 +0200 Subject: [PATCH 025/136] Simplify types --- .../Network/BlockFetch/Decision/BulkSync.hs | 54 ++++++++++--------- 1 file changed, 28 insertions(+), 26 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 308dd45deb3..77fe301b1c6 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -76,7 +76,7 @@ fetchDecisionsBulkSync -- Step 2: Select the peer to sync from. This eliminates peers that -- cannot serve a reasonable batch of the candidate, then chooses the -- peer to sync from, then again declines the others. - thePeer <- + (thePeerCandidate, thePeer) <- -- FIXME: make 'selectThePeer' return a 'WithDeclined'? withDeclined $ selectThePeer @@ -89,15 +89,16 @@ fetchDecisionsBulkSync -- Step 3: Fetch the candidate from the selected peer, potentially -- declining it (eg. if the peer is already too busy). - let decision = + let theDecision = fetchTheCandidate fetchDecisionPolicy fetchedBlocks fetchedMaxSlotNo theCandidate thePeer + thePeerCandidate - pure [decision] + pure [(theDecision, thePeer)] -- FIXME: The 'FetchDeclineConcurrencyLimit' should only be used for -- 'FetchModeDeadline', and 'FetchModeBulkSync' should have its own reasons. @@ -248,36 +249,37 @@ fetchTheCandidate :: -- | The candidate fragment that we have selected to sync from, as suffix of -- the immutable tip. ChainSuffix header -> - -- | The peer that we have selected to sync from, with its candidate fragment - -- as suffix of the immutable tip. - (ChainSuffix header, PeerInfo header peer extra) -> - (FetchDecision (FetchRequest header), PeerInfo header peer extra) + -- | The peer that we have selected to sync from. + PeerInfo header peer extra -> + -- | Its candidate fragment as suffix of the immutable tip. + ChainSuffix header -> + FetchDecision (FetchRequest header) fetchTheCandidate fetchDecisionPolicy fetchedBlocks fetchedMaxSlotNo theCandidate - (thePeerCandidate, thePeer@(status, inflight, gsvs, _, _)) = - (,thePeer) $ do - -- Keep blocks that have not already been downloaded or that are not - -- already in-flight with this peer. - fragments <- - filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate - >>= filterNotAlreadyInFlightWithPeer inflight + (status, inflight, gsvs, _, _) + thePeerCandidate = do + -- Keep blocks that have not already been downloaded or that are not + -- already in-flight with this peer. + fragments <- + filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate + >>= filterNotAlreadyInFlightWithPeer inflight - -- Trim the fragments to the peer's candidate, keeping only blocks that - -- they may actually serve. - trimmedFragments <- trimFragmentsToCandidate thePeerCandidate (snd fragments) + -- Trim the fragments to the peer's candidate, keeping only blocks that + -- they may actually serve. + trimmedFragments <- trimFragmentsToCandidate thePeerCandidate (snd fragments) - -- Try to create a request for those fragments. - fetchRequestDecision - fetchDecisionPolicy - FetchModeBulkSync - 0 -- bypass all concurrency limits. REVIEW: is this really what we want? - (calculatePeerFetchInFlightLimits gsvs) - inflight - status - (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. + -- Try to create a request for those fragments. + fetchRequestDecision + fetchDecisionPolicy + FetchModeBulkSync + 0 -- bypass all concurrency limits. REVIEW: is this really what we want? + (calculatePeerFetchInFlightLimits gsvs) + inflight + status + (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. where trimFragmentsToCandidate candidate fragments = let trimmedFragments = From 60ab44b14409d42648bf95713d0839b90e7da305 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 17 Jun 2024 14:13:46 +0200 Subject: [PATCH 026/136] Make `selectTheCandidate` return a `WithDeclined` --- .../Network/BlockFetch/Decision/BulkSync.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 77fe301b1c6..349e3d7bcf3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE RankNTypes #-} -- | This module contains the part of the block fetch decisions process that is -- specific to the bulk sync mode. @@ -66,8 +67,6 @@ fetchDecisionsBulkSync -- Step 1: Select the candidate to sync from. This already eliminates -- peers that have an implausible candidate. (theCandidate, candidatesAndPeers') <- - -- FIXME: make 'selectTheCandidate' return a 'WithDeclined'? - withDeclined $ selectTheCandidate fetchDecisionPolicy currentChain @@ -108,6 +107,7 @@ fetchDecisionsBulkSync -- still in race to serve it, and the list of peers that are already being -- declined. selectTheCandidate :: + forall header peerInfo. ( HasHeader header ) => FetchDecisionPolicy header -> @@ -119,9 +119,7 @@ selectTheCandidate :: -- because they presented us with a chain forking too deep, and (b) the -- selected candidate that we choose to sync from and a list of peers that are -- still in the race to serve that candidate. - ( Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)]), - [(FetchDecline, peerInfo)] - ) + WithDeclined peerInfo (ChainSuffix header, [(ChainSuffix header, peerInfo)]) selectTheCandidate FetchDecisionPolicy {plausibleCandidateChain} currentChain = @@ -136,10 +134,14 @@ selectTheCandidate . sortOn (Down . headBlockNo . fst) where -- Very ad-hoc helper. - separateDeclinedAndStillInRace :: [(Either a b, c)] -> (Maybe (b, [(b, c)]), [(a, c)]) + separateDeclinedAndStillInRace :: + [(FetchDecision (ChainSuffix header), peerInfo)] -> + WithDeclined peerInfo (ChainSuffix header, [(ChainSuffix header, peerInfo)]) separateDeclinedAndStillInRace xs = + -- FIXME: Make 'partitionEithersFirst' 'WithDeclined'-specific? let (declined, inRace) = partitionEithersFirst xs - in ( ((,inRace) . fst . NE.head) <$> nonEmpty inRace, + in withDeclined ( + ((,inRace) . fst . NE.head) <$> nonEmpty inRace, declined ) From 24ef98c17e368cb9bed9639deb2c481af9b4eb15 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 17 Jun 2024 16:01:20 +0200 Subject: [PATCH 027/136] Make `selectThePeer` return a `WithDeclined` --- .../Network/BlockFetch/Decision/BulkSync.hs | 88 ++++++++++--------- 1 file changed, 47 insertions(+), 41 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 349e3d7bcf3..6ec73cddc17 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -9,7 +9,8 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync ) where -import Control.Monad.Writer (Writer, runWriter, MonadWriter (writer)) +import Control.Monad (filterM, liftM) +import Control.Monad.Writer (Writer, runWriter, MonadWriter (writer, tell), MonadTrans (lift)) import Data.Bifunctor (first, Bifunctor (..)) import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) @@ -34,6 +35,12 @@ type WithDeclined peer = MaybeT (Writer [(FetchDecline, peer)]) withDeclined :: (Maybe a, [(FetchDecline, peer)]) -> WithDeclined peer a withDeclined = MaybeT . writer +decline :: FetchDecline -> peer -> WithDeclined peer () +decline reason peer = withDeclined (Just (), [(reason, peer)]) + +returnNothing :: WithDeclined peer a +returnNothing = withDeclined (Nothing, []) + runWithDeclined :: WithDeclined peer a -> (Maybe a, [(FetchDecline, peer)]) runWithDeclined = runWriter . runMaybeT @@ -76,8 +83,6 @@ fetchDecisionsBulkSync -- cannot serve a reasonable batch of the candidate, then chooses the -- peer to sync from, then again declines the others. (thePeerCandidate, thePeer) <- - -- FIXME: make 'selectThePeer' return a 'WithDeclined'? - withDeclined $ selectThePeer fetchDecisionPolicy fetchedBlocks @@ -149,6 +154,7 @@ selectTheCandidate -- -- PRECONDITION: The set of peers must be included in the peer order queue. selectThePeer :: + forall header block peer extra. ( HasHeader header, HeaderHash header ~ HeaderHash block, Eq peer @@ -164,31 +170,29 @@ selectThePeer :: -- | Association list of candidate fragments (as suffixes of the immutable -- tip) and their associated peers. [(ChainSuffix header, PeerInfo header peer extra)] -> - ( Maybe (ChainSuffix header, PeerInfo header peer extra), - [(FetchDecline, PeerInfo header peer extra)] - ) + WithDeclined (PeerInfo header peer extra) (ChainSuffix header, PeerInfo header peer extra) selectThePeer FetchDecisionPolicy {blockFetchSize} fetchedBlocks fetchedMaxSlotNo peersOrder theCandidate - candidates = - let -- Filter out from the chosen candidate fragment the blocks that have - -- already been downloaded, but keep the blocks that have a request in - -- flight. - fragments = + candidates = do + -- Filter out from the chosen candidate fragment the blocks that have + -- already been downloaded, but keep the blocks that have a request in + -- flight. + let fragments = snd <$> filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate - -- Create a fetch request for the blocks in question The request is made - -- to fit in 1MB but ignores everything else. It is gross in that sense. - -- It will only be used to choose the peer to fetch from, but we will - -- later craft a more refined request for that peer. - grossRequest = + -- Create a fetch request for the blocks in question The request is made + -- to fit in 1MB but ignores everything else. It is gross in that sense. + -- It will only be used to choose the peer to fetch from, but we will + -- later craft a more refined request for that peer. + let grossRequest = selectBlocksUpToLimits blockFetchSize 0 -- number of request in flight @@ -197,38 +201,36 @@ selectThePeer (1024 * 1024) -- maximum bytes in flight; one megabyte <$> fragments - -- For each peer, check whether its candidate contains the gross request - -- in its entirety, otherwise decline it. - peers = - map - ( first $ \candidate -> do - checkRequestInCandidate candidate =<< grossRequest - pure candidate + -- For each peer, check whether its candidate contains the gross request + -- in its entirety, otherwise decline it. + peers <- + filterM + ( \(candidate, peer) -> + case checkRequestInCandidate candidate =<< grossRequest of + Left reason -> decline reason peer >> pure False + Right () -> pure True ) candidates - -- Order the peers according to the peer order that we have been given, - -- then separate between declined peers and the others. - (declinedPeers, peersOrdered) = - partitionEithersFirst - [ (decision, peerInfo) - | (decision, peerInfo@(_, _, _, peer, _)) <- peers, + -- Order the peers according to the peer order that we have been given, + -- then separate between declined peers and the others. + let peersOrdered = + [ (candidate, peerInfo) + | (candidate, peerInfo@(_, _, _, peer, _)) <- peers, peer' <- peersOrder, peer == peer' ] - in -- Return the first peer in that order, and decline all the ones that were - -- not already declined. - case peersOrdered of - [] -> - ( Nothing, - declinedPeers - ) - (thePeerCandidate, thePeer) : otherPeers -> - ( Just (thePeerCandidate, thePeer), - declinedPeers - ++ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers - ) + + -- Return the first peer in that order, and decline all the ones that were + -- not already declined. + case peersOrdered of + [] -> returnNothing + (thePeerCandidate, thePeer) : otherPeers -> do + lift $ tell $ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers + pure (thePeerCandidate, thePeer) where + checkRequestInCandidate :: + HasHeader header => ChainSuffix header -> FetchRequest header -> FetchDecision () checkRequestInCandidate candidate request = if all isSubfragmentOfCandidate $ fetchRequestFragments request then pure () @@ -355,3 +357,7 @@ instance (Monad m) => Monad (MaybeT m) where {-# INLINE (>>=) #-} -- fail _ = MaybeT (return Nothing) -- {-# INLINE fail #-} + +instance MonadTrans MaybeT where + lift = MaybeT . liftM Just + {-# INLINE lift #-} From d56d2c5a7e03226467e2f374a7790b5df9d68ab1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 17 Jun 2024 16:47:55 +0200 Subject: [PATCH 028/136] Use actual `transformers` --- ouroboros-network/ouroboros-network.cabal | 1 + .../Network/BlockFetch/Decision/BulkSync.hs | 59 +------------------ 2 files changed, 3 insertions(+), 57 deletions(-) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 75957e35208..33470e378ef 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -124,6 +124,7 @@ library nothunks, psqueues >=0.2.3 && <0.3, random, + transformers, cardano-prelude, cardano-slotting, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 6ec73cddc17..ecda51f1c4e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -9,7 +9,8 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync ) where -import Control.Monad (filterM, liftM) +import Control.Monad (filterM) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer (Writer, runWriter, MonadWriter (writer, tell), MonadTrans (lift)) import Data.Bifunctor (first, Bifunctor (..)) import Data.List (sortOn) @@ -305,59 +306,3 @@ partitionEithersFirst = Right b -> (as, (b, c) : bs) ) ([], []) - --------------------------------------------------------------------------------- --- The following is copied from package `transformers` 0.6.1.1. - --- | The parameterizable maybe monad, obtained by composing an arbitrary --- monad with the 'Maybe' monad. --- --- Computations are actions that may produce a value or exit. --- --- The 'return' function yields a computation that produces that --- value, while @>>=@ sequences two subcomputations, exiting if either --- computation does. -newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } - --- | Transform the computation inside a @MaybeT@. --- --- * @'runMaybeT' ('mapMaybeT' f m) = f ('runMaybeT' m)@ -mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b -mapMaybeT f = MaybeT . f . runMaybeT -{-# INLINE mapMaybeT #-} - -instance (Functor m) => Functor (MaybeT m) where - fmap f = mapMaybeT (fmap (fmap f)) - {-# INLINE fmap #-} - -instance (Functor m, Monad m) => Applicative (MaybeT m) where - pure = MaybeT . return . Just - {-# INLINE pure #-} - mf <*> mx = MaybeT $ do - mb_f <- runMaybeT mf - case mb_f of - Nothing -> return Nothing - Just f -> do - mb_x <- runMaybeT mx - case mb_x of - Nothing -> return Nothing - Just x -> return (Just (f x)) - {-# INLINE (<*>) #-} - m *> k = m >>= \_ -> k - {-# INLINE (*>) #-} - -instance (Monad m) => Monad (MaybeT m) where - -- return = MaybeT . return . Just - -- {-# INLINE return #-} - x >>= f = MaybeT $ do - v <- runMaybeT x - case v of - Nothing -> return Nothing - Just y -> runMaybeT (f y) - {-# INLINE (>>=) #-} - -- fail _ = MaybeT (return Nothing) - -- {-# INLINE fail #-} - -instance MonadTrans MaybeT where - lift = MaybeT . liftM Just - {-# INLINE lift #-} From 7ac4bb5ced197eabf17667e80bb068ee40e7d991 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 17 Jun 2024 16:54:54 +0200 Subject: [PATCH 029/136] Remove `MaybeT` from `WithDeclined` --- .../Network/BlockFetch/Decision/BulkSync.hs | 77 +++++++++---------- 1 file changed, 36 insertions(+), 41 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index ecda51f1c4e..cb297f7d415 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -11,7 +11,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( import Control.Monad (filterM) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) -import Control.Monad.Writer (Writer, runWriter, MonadWriter (writer, tell), MonadTrans (lift)) +import Control.Monad.Writer (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) @@ -31,22 +31,10 @@ import Ouroboros.Network.BlockFetch.Decision.Common -- arises, we should move the interesting piece of code to 'Decision.Common'. -- This is to be done on demand. -type WithDeclined peer = MaybeT (Writer [(FetchDecline, peer)]) +type WithDeclined peer = Writer [(FetchDecline, peer)] -withDeclined :: (Maybe a, [(FetchDecline, peer)]) -> WithDeclined peer a -withDeclined = MaybeT . writer - -decline :: FetchDecline -> peer -> WithDeclined peer () -decline reason peer = withDeclined (Just (), [(reason, peer)]) - -returnNothing :: WithDeclined peer a -returnNothing = withDeclined (Nothing, []) - -runWithDeclined :: WithDeclined peer a -> (Maybe a, [(FetchDecline, peer)]) -runWithDeclined = runWriter . runMaybeT - -combineWithDeclined :: WithDeclined peer [(FetchDecision a, peer)] -> [(FetchDecision a, peer)] -combineWithDeclined = uncurry (++) . bimap (fromMaybe []) (map (first Left)) . runWithDeclined +runWithDeclined :: WithDeclined peer a -> (a, [(FetchDecline, peer)]) +runWithDeclined = runWriter -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. @@ -75,6 +63,7 @@ fetchDecisionsBulkSync -- Step 1: Select the candidate to sync from. This already eliminates -- peers that have an implausible candidate. (theCandidate, candidatesAndPeers') <- + MaybeT $ selectTheCandidate fetchDecisionPolicy currentChain @@ -84,6 +73,7 @@ fetchDecisionsBulkSync -- cannot serve a reasonable batch of the candidate, then chooses the -- peer to sync from, then again declines the others. (thePeerCandidate, thePeer) <- + MaybeT $ selectThePeer fetchDecisionPolicy fetchedBlocks @@ -104,6 +94,9 @@ fetchDecisionsBulkSync thePeerCandidate pure [(theDecision, thePeer)] + where + combineWithDeclined :: MaybeT (WithDeclined peer) [(FetchDecision a, peer)] -> [(FetchDecision a, peer)] + combineWithDeclined = uncurry (++) . bimap (fromMaybe []) (map (first Left)) . runWithDeclined . runMaybeT -- FIXME: The 'FetchDeclineConcurrencyLimit' should only be used for -- 'FetchModeDeadline', and 'FetchModeBulkSync' should have its own reasons. @@ -125,7 +118,9 @@ selectTheCandidate :: -- because they presented us with a chain forking too deep, and (b) the -- selected candidate that we choose to sync from and a list of peers that are -- still in the race to serve that candidate. - WithDeclined peerInfo (ChainSuffix header, [(ChainSuffix header, peerInfo)]) + WithDeclined + peerInfo + (Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)])) selectTheCandidate FetchDecisionPolicy {plausibleCandidateChain} currentChain = @@ -142,14 +137,12 @@ selectTheCandidate -- Very ad-hoc helper. separateDeclinedAndStillInRace :: [(FetchDecision (ChainSuffix header), peerInfo)] -> - WithDeclined peerInfo (ChainSuffix header, [(ChainSuffix header, peerInfo)]) - separateDeclinedAndStillInRace xs = + WithDeclined peerInfo (Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)])) + separateDeclinedAndStillInRace xs = do -- FIXME: Make 'partitionEithersFirst' 'WithDeclined'-specific? let (declined, inRace) = partitionEithersFirst xs - in withDeclined ( - ((,inRace) . fst . NE.head) <$> nonEmpty inRace, - declined - ) + tell declined + pure $ ((,inRace) . fst . NE.head) <$> nonEmpty inRace -- | -- @@ -171,7 +164,9 @@ selectThePeer :: -- | Association list of candidate fragments (as suffixes of the immutable -- tip) and their associated peers. [(ChainSuffix header, PeerInfo header peer extra)] -> - WithDeclined (PeerInfo header peer extra) (ChainSuffix header, PeerInfo header peer extra) + WithDeclined + (PeerInfo header peer extra) + (Maybe (ChainSuffix header, PeerInfo header peer extra)) selectThePeer FetchDecisionPolicy {blockFetchSize} fetchedBlocks @@ -205,33 +200,33 @@ selectThePeer -- For each peer, check whether its candidate contains the gross request -- in its entirety, otherwise decline it. peers <- - filterM - ( \(candidate, peer) -> - case checkRequestInCandidate candidate =<< grossRequest of - Left reason -> decline reason peer >> pure False - Right () -> pure True - ) - candidates + filterM + ( \(candidate, peer) -> + case checkRequestInCandidate candidate =<< grossRequest of + Left reason -> tell [(reason, peer)] >> pure False + Right () -> pure True + ) + candidates -- Order the peers according to the peer order that we have been given, -- then separate between declined peers and the others. let peersOrdered = - [ (candidate, peerInfo) - | (candidate, peerInfo@(_, _, _, peer, _)) <- peers, - peer' <- peersOrder, - peer == peer' - ] + [ (candidate, peerInfo) + | (candidate, peerInfo@(_, _, _, peer, _)) <- peers, + peer' <- peersOrder, + peer == peer' + ] -- Return the first peer in that order, and decline all the ones that were -- not already declined. case peersOrdered of - [] -> returnNothing - (thePeerCandidate, thePeer) : otherPeers -> do - lift $ tell $ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers - pure (thePeerCandidate, thePeer) + [] -> return Nothing + (thePeerCandidate, thePeer) : otherPeers -> do + tell $ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers + return $ Just (thePeerCandidate, thePeer) where checkRequestInCandidate :: - HasHeader header => ChainSuffix header -> FetchRequest header -> FetchDecision () + (HasHeader header) => ChainSuffix header -> FetchRequest header -> FetchDecision () checkRequestInCandidate candidate request = if all isSubfragmentOfCandidate $ fetchRequestFragments request then pure () From 4771b825805245c665f7299922173e7fd777e715 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 17 Jun 2024 17:05:24 +0200 Subject: [PATCH 030/136] Inline `partitionEithersFirst` --- .../Network/BlockFetch/Decision/BulkSync.hs | 28 ++++++++----------- 1 file changed, 12 insertions(+), 16 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index cb297f7d415..1ea8c7693b4 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -16,7 +16,7 @@ import Data.Bifunctor (first, Bifunctor (..)) import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import Data.Ord (Down(Down)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) @@ -138,11 +138,17 @@ selectTheCandidate separateDeclinedAndStillInRace :: [(FetchDecision (ChainSuffix header), peerInfo)] -> WithDeclined peerInfo (Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)])) - separateDeclinedAndStillInRace xs = do - -- FIXME: Make 'partitionEithersFirst' 'WithDeclined'-specific? - let (declined, inRace) = partitionEithersFirst xs - tell declined - pure $ ((,inRace) . fst . NE.head) <$> nonEmpty inRace + separateDeclinedAndStillInRace decisions = do + inRace <- + catMaybes + <$> traverse + ( \(decision, peer) -> + case decision of + Left reason -> tell [(reason, peer)] >> pure Nothing + Right candidate -> pure $ Just (candidate, peer) + ) + decisions + return $ ((,inRace) . fst . NE.head) <$> nonEmpty inRace -- | -- @@ -291,13 +297,3 @@ fetchTheCandidate in if null trimmedFragments then Left FetchDeclineAlreadyFetched else Right trimmedFragments - --- | Partition eithers on the first component of the pair. -partitionEithersFirst :: [(Either a b, c)] -> ([(a, c)], [(b, c)]) -partitionEithersFirst = - foldr - ( \(e, c) (as, bs) -> case e of - Left a -> ((a, c) : as, bs) - Right b -> (as, (b, c) : bs) - ) - ([], []) From 2953e5a54517b0647a8ba8bc570e77288dea8d0a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 17 Jun 2024 17:08:04 +0200 Subject: [PATCH 031/136] Some documentation --- .../Network/BlockFetch/Decision/BulkSync.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 1ea8c7693b4..e5ab8488b7c 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -60,8 +60,9 @@ fetchDecisionsBulkSync fetchedMaxSlotNo peersOrder candidatesAndPeers = combineWithDeclined $ do - -- Step 1: Select the candidate to sync from. This already eliminates - -- peers that have an implausible candidate. + -- Step 1: Select the candidate to sync from. This already eliminates peers + -- that have an implausible candidate. It returns the remaining candidates + -- (with their corresponding peer) as suffixes of the immutable tip. (theCandidate, candidatesAndPeers') <- MaybeT $ selectTheCandidate @@ -69,9 +70,9 @@ fetchDecisionsBulkSync currentChain candidatesAndPeers - -- Step 2: Select the peer to sync from. This eliminates peers that - -- cannot serve a reasonable batch of the candidate, then chooses the - -- peer to sync from, then again declines the others. + -- Step 2: Select the peer to sync from. This eliminates peers that cannot + -- serve a reasonable batch of the candidate, then chooses the peer to sync + -- from, then again declines the others. (thePeerCandidate, thePeer) <- MaybeT $ selectThePeer @@ -82,8 +83,8 @@ fetchDecisionsBulkSync theCandidate candidatesAndPeers' - -- Step 3: Fetch the candidate from the selected peer, potentially - -- declining it (eg. if the peer is already too busy). + -- Step 3: Fetch the candidate from the selected peer, potentially declining + -- it (eg. if the peer is already too busy). let theDecision = fetchTheCandidate fetchDecisionPolicy From 238eb08ecc237dbd16c1ba0d44cd00f790a5be1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 17 Jun 2024 17:12:58 +0200 Subject: [PATCH 032/136] Document `selectThePeer` --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index e5ab8488b7c..e9fb65c3e5c 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -151,7 +151,13 @@ selectTheCandidate decisions return $ ((,inRace) . fst . NE.head) <$> nonEmpty inRace --- | +-- | Given _the_ candidate fragment to sync from, and a list of peers (with +-- their corresponding candidate fragments), choose which peer to sync _the_ +-- candidate fragment from. +-- +-- We first filter out all the peers that cannot even serve a reasonable batch +-- of _the_ candidate fragment, and then we choose the first one according to +-- the ordering passed as argument. -- -- PRECONDITION: The set of peers must be included in the peer order queue. selectThePeer :: From 7c636585030d62f7ddd872fe9151d5f0131dd04f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 20 Jun 2024 17:48:40 +0200 Subject: [PATCH 033/136] Add the last ChainSel starvation time to consensus interface --- .../src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index 5958f8fa467..10ae86ed97e 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -10,6 +10,7 @@ module Ouroboros.Network.BlockFetch.ConsensusInterface import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime (UTCTime) +import Control.Monad.Class.MonadTime.SI (Time) import Data.Map.Strict (Map) import GHC.Stack (HasCallStack) @@ -153,6 +154,10 @@ data BlockFetchConsensusInterface peer header block m = -- WARNING: Same as 'headerForgeUTCTime'. blockForgeUTCTime :: FromConsensus block -> STM m UTCTime, + -- | The last time that the Chain Selection pipeline was starved, that is + -- it tried to pop a block but there wasn't any. + lastChainSelStarvation :: STM m Time, + -- | Action to inform CSJ that the given peer has not been performing -- adequately with respect to BlockFetch, and that it should be demoted -- from the dynamo role. Can be set to @const (pure ())@ in all other From 43951c4d92e8558be1ee9a60d19b1ae298c3d99c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 25 Jun 2024 11:04:51 +0200 Subject: [PATCH 034/136] Make `peerFetchBlocksInFlight` a map --- .../Ouroboros/Network/BlockFetch/Client.hs | 4 +- .../Network/BlockFetch/ClientRegistry.hs | 2 +- .../Network/BlockFetch/ClientState.hs | 45 ++++++++++++------- .../Network/BlockFetch/Decision/Common.hs | 4 +- 4 files changed, 34 insertions(+), 21 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs index ca47dd93e0d..3f6ccd847fb 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs @@ -26,7 +26,7 @@ import Control.Monad (unless) import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI -import Data.Set qualified as Set +import qualified Data.Map.Strict as Map import Control.Tracer (traceWith) @@ -117,7 +117,7 @@ blockFetchClient _version controlMessageSTM reportFetched assert ( peerFetchReqsInFlight == 0 && peerFetchBytesInFlight == 0 && - Set.null peerFetchBlocksInFlight ) + Map.null peerFetchBlocksInFlight ) $ pure (senderAwait Zero) senderAwait :: forall n. diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientRegistry.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientRegistry.hs index bdbdb01da23..65098f3ce66 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientRegistry.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientRegistry.hs @@ -144,7 +144,7 @@ bracketFetchClient (FetchClientRegistry ctxVar Just (cTid, doneVar, startVar) -> do putTMVar startVar () writeTVar (fetchClientStatusVar $ fetchClientCtxStateVars ctx) - (PeerFetchStatusReady Set.empty IsIdle) + (PeerFetchStatusReady Map.empty IsIdle) return (ctx, (cTid, doneVar)) ) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index 8e25804f662..e240abf96c0 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -18,6 +18,7 @@ module Ouroboros.Network.BlockFetch.ClientState , PeerFetchStatus (..) , IsIdle (..) , PeerFetchInFlight (..) + , PeerFetchBlockInFlight (..) , initialPeerFetchInFlight , FetchRequest (..) , addNewFetchRequest @@ -32,13 +33,14 @@ module Ouroboros.Network.BlockFetch.ClientState -- * Ancillary , FromConsensus (..) , WhetherReceivingTentativeBlocks (..) + , defaultPeerFetchBlockInFlight ) where import Data.List (foldl') import Data.Maybe (mapMaybe) import Data.Semigroup (Last (..)) -import Data.Set (Set) -import Data.Set qualified as Set +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) @@ -177,7 +179,7 @@ data PeerFetchStatus header = -- considered ready to accept new requests. -- -- The 'Set' is the blocks in flight. - | PeerFetchStatusReady (Set (Point header)) IsIdle + | PeerFetchStatusReady (Map (Point header) PeerFetchBlockInFlight) IsIdle deriving (Eq, Show) -- | Whether this mini protocol instance is in the @Idle@ State @@ -219,7 +221,7 @@ data PeerFetchInFlight header = PeerFetchInFlight { -- fetch from which peers we take into account what blocks are already -- in-flight with peers. -- - peerFetchBlocksInFlight :: Set (Point header), + peerFetchBlocksInFlight :: Map (Point header) PeerFetchBlockInFlight, -- | The maximum slot of a block that /has ever been/ in flight for -- this peer. @@ -231,12 +233,19 @@ data PeerFetchInFlight header = PeerFetchInFlight { } deriving (Eq, Show) +-- | Information associated to a block in flight. +data PeerFetchBlockInFlight = PeerFetchBlockInFlight + deriving (Eq, Show) + +defaultPeerFetchBlockInFlight :: PeerFetchBlockInFlight +defaultPeerFetchBlockInFlight = PeerFetchBlockInFlight + initialPeerFetchInFlight :: PeerFetchInFlight header initialPeerFetchInFlight = PeerFetchInFlight { peerFetchReqsInFlight = 0, peerFetchBytesInFlight = 0, - peerFetchBlocksInFlight = Set.empty, + peerFetchBlocksInFlight = Map.empty, peerFetchMaxSlotNo = NoMaxSlotNo } @@ -258,7 +267,7 @@ addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight = -- This assertion checks the pre-condition 'addNewFetchRequest' that all -- requested blocks are new. This is true irrespective of fetch-request -- command merging. - assert (and [ blockPoint header `Set.notMember` peerFetchBlocksInFlight inflight + assert (and [ blockPoint header `Map.notMember` peerFetchBlocksInFlight inflight | fragment <- fetchRequestFragments addedReq , header <- AF.toOldestFirst fragment ]) $ @@ -280,11 +289,15 @@ addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight = | fragment <- fetchRequestFragments addedReq , header <- AF.toOldestFirst fragment ], - peerFetchBlocksInFlight = peerFetchBlocksInFlight inflight - `Set.union` Set.fromList - [ blockPoint header - | fragment <- fetchRequestFragments addedReq - , header <- AF.toOldestFirst fragment ], + peerFetchBlocksInFlight = + Map.unionWith + (\_ _ -> error "addHeadersInFlight: precondition violated") + (peerFetchBlocksInFlight inflight) + ( Map.fromList + [ (blockPoint header, PeerFetchBlockInFlight) + | fragment <- fetchRequestFragments addedReq + , header <- AF.toOldestFirst fragment ] + ), peerFetchMaxSlotNo = peerFetchMaxSlotNo inflight `max` fetchRequestMaxSlotNo addedReq @@ -300,13 +313,13 @@ deleteHeaderInFlight :: HasHeader header -> PeerFetchInFlight header deleteHeaderInFlight blockFetchSize header inflight = assert (peerFetchBytesInFlight inflight >= blockFetchSize header) $ - assert (blockPoint header `Set.member` peerFetchBlocksInFlight inflight) $ + assert (blockPoint header `Map.member` peerFetchBlocksInFlight inflight) $ inflight { peerFetchBytesInFlight = peerFetchBytesInFlight inflight - blockFetchSize header, peerFetchBlocksInFlight = blockPoint header - `Set.delete` peerFetchBlocksInFlight inflight + `Map.delete` peerFetchBlocksInFlight inflight } deleteHeadersInFlight :: HasHeader header @@ -592,7 +605,7 @@ completeFetchBatch tracer inflightlimits range let !inflight' = assert (if peerFetchReqsInFlight inflight == 1 then peerFetchBytesInFlight inflight == 0 - && Set.null (peerFetchBlocksInFlight inflight) + && Map.null (peerFetchBlocksInFlight inflight) else True) inflight { peerFetchReqsInFlight = peerFetchReqsInFlight inflight - 1 @@ -600,9 +613,9 @@ completeFetchBatch tracer inflightlimits range writeTVar fetchClientInFlightVar inflight' currentStatus' <- readTVar fetchClientStatusVar >>= \case PeerFetchStatusReady bs IsNotIdle - | Set.null bs + | Map.null bs && 0 == peerFetchReqsInFlight inflight' - -> let status = PeerFetchStatusReady Set.empty IsIdle + -> let status = PeerFetchStatusReady Map.empty IsIdle in status <$ writeTVar fetchClientStatusVar status currentStatus -> pure currentStatus diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index 6faa09c9f4d..fd1a579bc6a 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -28,7 +28,7 @@ import GHC.Stack (HasCallStack) import Control.Exception (assert) import Control.Monad (guard) import Control.Monad.Class.MonadTime.SI (DiffTime) -import qualified Data.Set as Set +import qualified Data.Map.Strict as Map import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq (..)) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -437,7 +437,7 @@ filterNotAlreadyInFlightWithPeer inflight (candidate, chainfragments) = else Right (candidate, fragments) where fragments = concatMap (filterWithMaxSlotNo notAlreadyInFlight (peerFetchMaxSlotNo inflight)) chainfragments - notAlreadyInFlight b = blockPoint b `Set.notMember` peerFetchBlocksInFlight inflight + notAlreadyInFlight b = blockPoint b `Map.notMember` peerFetchBlocksInFlight inflight filterNotAlreadyInFlightWithPeer' :: (HasHeader header) => From 3a284db8c684f8c3380a36ff2f895dc76fb37dce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 25 Jun 2024 11:09:04 +0200 Subject: [PATCH 035/136] Record the time at which a block was requested --- .../Network/BlockFetch/ClientState.hs | 20 ++++++++++++------- .../src/Ouroboros/Network/BlockFetch/State.hs | 5 +++-- 2 files changed, 16 insertions(+), 9 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index e240abf96c0..a4446692d8c 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -235,10 +235,14 @@ data PeerFetchInFlight header = PeerFetchInFlight { -- | Information associated to a block in flight. data PeerFetchBlockInFlight = PeerFetchBlockInFlight + { -- | The time at which the block was requested. + peerFetchBlockReqTime :: Time + } deriving (Eq, Show) -defaultPeerFetchBlockInFlight :: PeerFetchBlockInFlight -defaultPeerFetchBlockInFlight = PeerFetchBlockInFlight +defaultPeerFetchBlockInFlight :: Time -> PeerFetchBlockInFlight +defaultPeerFetchBlockInFlight peerFetchBlockReqTime = + PeerFetchBlockInFlight {peerFetchBlockReqTime} initialPeerFetchInFlight :: PeerFetchInFlight header initialPeerFetchInFlight = @@ -256,13 +260,14 @@ initialPeerFetchInFlight = -- @old <> added = merged@. -- addHeadersInFlight :: HasHeader header - => (header -> SizeInBytes) + => Time -- ^ The current time + -> (header -> SizeInBytes) -> Maybe (FetchRequest header) -- ^ The old request (if any). -> FetchRequest header -- ^ The added request. -> FetchRequest header -- ^ The merged request. -> PeerFetchInFlight header -> PeerFetchInFlight header -addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight = +addHeadersInFlight reqTime blockFetchSize oldReq addedReq mergedReq inflight = -- This assertion checks the pre-condition 'addNewFetchRequest' that all -- requested blocks are new. This is true irrespective of fetch-request @@ -294,7 +299,7 @@ addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight = (\_ _ -> error "addHeadersInFlight: precondition violated") (peerFetchBlocksInFlight inflight) ( Map.fromList - [ (blockPoint header, PeerFetchBlockInFlight) + [ (blockPoint header, defaultPeerFetchBlockInFlight reqTime) | fragment <- fetchRequestFragments addedReq , header <- AF.toOldestFirst fragment ] ), @@ -454,7 +459,7 @@ data TraceFetchClientState header = -- only operation that grows the in-flight blocks, and is only used by the -- fetch decision logic thread. -- -addNewFetchRequest :: (MonadSTM m, HasHeader header) +addNewFetchRequest :: (MonadSTM m, HasHeader header, MonadMonotonicTime m) => Tracer m (TraceFetchClientState header) -> (header -> SizeInBytes) -> FetchRequest header @@ -467,6 +472,7 @@ addNewFetchRequest tracer blockFetchSize addedReq gsvs fetchClientInFlightVar, fetchClientStatusVar } = do + reqTime <- getMonotonicTime (inflight', currentStatus') <- atomically $ do -- Add a new fetch request, or extend or merge with the existing @@ -484,7 +490,7 @@ addNewFetchRequest tracer blockFetchSize addedReq gsvs -- Update our in-flight stats inflight <- readTVar fetchClientInFlightVar - let !inflight' = addHeadersInFlight blockFetchSize + let !inflight' = addHeadersInFlight reqTime blockFetchSize oldReq addedReq mergedReq inflight writeTVar fetchClientInFlightVar inflight' diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 73b4bb3531a..3550fcea157 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -101,7 +101,8 @@ iterateForever x0 m = go x0 where go x = m x >>= go fetchLogicIteration :: (Hashable peer, MonadSTM m, Ord peer, HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) + HeaderHash header ~ HeaderHash block, + MonadMonotonicTime m) => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])] -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) -> FetchDecisionPolicy header @@ -215,7 +216,7 @@ fetchDecisionsForStateSnapshot -- request variables that are shared with the threads running the block fetch -- protocol with each peer. -- -fetchLogicIterationAct :: (MonadSTM m, HasHeader header) +fetchLogicIterationAct :: (MonadSTM m, HasHeader header, MonadMonotonicTime m) => Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) -> FetchDecisionPolicy header -> [(FetchDecision (FetchRequest header), From a44198ae49ecc01f3d6de65f826d0ab52d4a48c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 25 Jun 2024 11:29:21 +0200 Subject: [PATCH 036/136] Wrapper type for `PeersOrder` ...on the way to tracking the currently-chosen peer --- .../src/Ouroboros/Network/BlockFetch.hs | 32 +++++++++++-------- .../Network/BlockFetch/ClientState.hs | 5 +++ .../Ouroboros/Network/BlockFetch/Decision.hs | 4 +-- .../Network/BlockFetch/Decision/BulkSync.hs | 10 +++--- .../src/Ouroboros/Network/BlockFetch/State.hs | 6 ++-- 5 files changed, 32 insertions(+), 25 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index d1dec25e589..b69bf414ae7 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -120,6 +120,7 @@ import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientPolicy (..), bracketSyncWithFetchClient, newFetchClientRegistry, readFetchClientsStateVars, readFetchClientsStatus, readPeerGSVs, setFetchClientContext) +import Ouroboros.Network.BlockFetch.ClientState (PeersOrder (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (BlockFetchConsensusInterface (..), FromConsensus (..), WhetherReceivingTentativeBlocks (..)) @@ -177,7 +178,7 @@ blockFetchLogic decisionTracer clientStateTracer setFetchClientContext registry clientStateTracer mkFetchClientPolicy - peersOrderVar <- newTVarIO [] + peersOrderVar <- newTVarIO $ PeersOrder [] fetchLogicIterations decisionTracer clientStateTracer @@ -219,7 +220,7 @@ blockFetchLogic decisionTracer clientStateTracer } fetchNonTriggerVariables :: - StrictTVar m [addr] -> + StrictTVar m (PeersOrder addr) -> FetchNonTriggerVariables addr header block m fetchNonTriggerVariables peersOrderVar = FetchNonTriggerVariables { @@ -228,27 +229,29 @@ blockFetchLogic decisionTracer clientStateTracer readStatePeerGSVs = readPeerGSVs registry, readStateFetchMode = readFetchMode, readStateFetchedMaxSlotNo = readFetchedMaxSlotNo, - readStatePeersOrder = readPeersOrder peersOrderVar readCandidateChains + readStatePeersOrder = readUpdatePeersOrder peersOrderVar readCandidateChains } -- | Read the current peers order from the TVar, update it according to the -- current peers, and return the updated order. -readPeersOrder :: +readUpdatePeersOrder :: ( MonadSTM m, Eq addr ) => -- | The TVar containing the current order of peers. - StrictTVar m [addr] -> + StrictTVar m (PeersOrder addr) -> -- | An STM action to read all the current peers. This can for instance be -- 'readCandidateChains'. STM m (Map addr whatever) -> - STM m [addr] -readPeersOrder peersOrderVar readPeers = do - peersOrder <- readTVar peersOrderVar + STM m (PeersOrder addr) +readUpdatePeersOrder peersOrderVar readPeers = do + PeersOrder{peersOrderAll} + <- readTVar peersOrderVar currentPeers <- Map.keys <$> readPeers - let peersOrder' = - filter (`elem` currentPeers) peersOrder - ++ filter (`notElem` peersOrder) currentPeers + let peersOrderAll' = + filter (`elem` currentPeers) peersOrderAll + ++ filter (`notElem` peersOrderAll) currentPeers + peersOrder' = PeersOrder peersOrderAll' writeTVar peersOrderVar peersOrder' pure peersOrder' @@ -263,14 +266,15 @@ reportBadPeer :: -- (CSJ) in the consensus layer. (peer -> m ()) -> -- | The TVar containing the current order of peers. - StrictTVar m [peer] -> + StrictTVar m (PeersOrder peer) -> -- | The peer that we know is a bad peer (e.g. because it has not respected -- our syncing BlockFetch timeouts). peer -> m () reportBadPeer demoteCSJDynamo peersOrderVar peer = do atomically $ do - peersOrder <- readTVar peersOrderVar - let peersOrder' = filter (/= peer) peersOrder ++ [peer] + PeersOrder {peersOrderAll} <- readTVar peersOrderVar + let peersOrderAll' = filter (/= peer) peersOrderAll ++ [peer] + peersOrder' = PeersOrder peersOrderAll' writeTVar peersOrderVar peersOrder' demoteCSJDynamo peer diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index a4446692d8c..c04b7fc28b7 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -34,6 +34,7 @@ module Ouroboros.Network.BlockFetch.ClientState , FromConsensus (..) , WhetherReceivingTentativeBlocks (..) , defaultPeerFetchBlockInFlight + , PeersOrder(..) ) where import Data.List (foldl') @@ -804,3 +805,7 @@ tryReadTMergeVar :: MonadSTM m => TMergeVar m a -> STM m (Maybe a) tryReadTMergeVar (TMergeVar v) = tryReadTMVar v + +data PeersOrder peer = PeersOrder + { peersOrderAll :: [peer] + } diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 5f9bb8becd0..f80bc2cac93 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -25,7 +25,7 @@ module Ouroboros.Network.BlockFetch.Decision import Data.Hashable import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), @@ -45,7 +45,7 @@ fetchDecisions -> AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo - -> [peer] -- ^ Order of the peers for syncing purposes + -> PeersOrder peer -> [(AnchoredFragment header, PeerInfo header peer extra)] -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index e9fb65c3e5c..2841c5db117 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -22,7 +22,7 @@ import Data.Ord (Down(Down)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) @@ -47,8 +47,7 @@ fetchDecisionsBulkSync :: AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo -> - -- | Order of the peers, from most to least preferred. - [peer] -> + PeersOrder peer -> -- | Association list of the candidate fragments and their associated peers. [(AnchoredFragment header, PeerInfo header peer extra)] -> -- | Association list of the requests and their associated peers. @@ -169,8 +168,7 @@ selectThePeer :: FetchDecisionPolicy header -> (Point block -> Bool) -> MaxSlotNo -> - -- | Order of the peers, from most to least preferred. - [peer] -> + PeersOrder peer -> -- | The candidate fragment that we have selected to sync from, as suffix of -- the immutable tip. ChainSuffix header -> @@ -226,7 +224,7 @@ selectThePeer let peersOrdered = [ (candidate, peerInfo) | (candidate, peerInfo@(_, _, _, peer, _)) <- peers, - peer' <- peersOrder, + peer' <- peersOrderAll peersOrder, peer == peer' ] diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 3550fcea157..8578d56d806 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -37,7 +37,7 @@ import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchClientStateVars (..), FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..), TraceFetchClientState (..), TraceLabelPeer (..), addNewFetchRequest, - readFetchClientState) + readFetchClientState, PeersOrder) import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecisionPolicy (..), FetchDecline (..), FetchMode (..), PeerInfo, fetchDecisions) @@ -261,7 +261,7 @@ data FetchNonTriggerVariables peer header block m = FetchNonTriggerVariables { readStatePeerGSVs :: STM m (Map peer PeerGSV), readStateFetchMode :: STM m FetchMode, readStateFetchedMaxSlotNo :: STM m MaxSlotNo, - readStatePeersOrder :: STM m [peer] + readStatePeersOrder :: STM m (PeersOrder peer) } @@ -305,7 +305,7 @@ data FetchStateSnapshot peer header block m = FetchStateSnapshot { fetchStateFetchedBlocks :: Point block -> Bool, fetchStateFetchMode :: FetchMode, fetchStateFetchedMaxSlotNo :: MaxSlotNo, - fetchStatePeersOrder :: [peer] + fetchStatePeersOrder :: PeersOrder peer } readStateVariables :: (MonadSTM m, Eq peer, From d4e295d2fa6eb934704cf4517927e7e2795d49ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 25 Jun 2024 15:12:37 +0200 Subject: [PATCH 037/136] Revert "Record the time at which a block was requested" This reverts commit 3a284db8c684f8c3380a36ff2f895dc76fb37dce. --- .../Network/BlockFetch/ClientState.hs | 20 +++++++------------ .../src/Ouroboros/Network/BlockFetch/State.hs | 5 ++--- 2 files changed, 9 insertions(+), 16 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index c04b7fc28b7..d1efcd69190 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -236,14 +236,10 @@ data PeerFetchInFlight header = PeerFetchInFlight { -- | Information associated to a block in flight. data PeerFetchBlockInFlight = PeerFetchBlockInFlight - { -- | The time at which the block was requested. - peerFetchBlockReqTime :: Time - } deriving (Eq, Show) -defaultPeerFetchBlockInFlight :: Time -> PeerFetchBlockInFlight -defaultPeerFetchBlockInFlight peerFetchBlockReqTime = - PeerFetchBlockInFlight {peerFetchBlockReqTime} +defaultPeerFetchBlockInFlight :: PeerFetchBlockInFlight +defaultPeerFetchBlockInFlight = PeerFetchBlockInFlight initialPeerFetchInFlight :: PeerFetchInFlight header initialPeerFetchInFlight = @@ -261,14 +257,13 @@ initialPeerFetchInFlight = -- @old <> added = merged@. -- addHeadersInFlight :: HasHeader header - => Time -- ^ The current time - -> (header -> SizeInBytes) + => (header -> SizeInBytes) -> Maybe (FetchRequest header) -- ^ The old request (if any). -> FetchRequest header -- ^ The added request. -> FetchRequest header -- ^ The merged request. -> PeerFetchInFlight header -> PeerFetchInFlight header -addHeadersInFlight reqTime blockFetchSize oldReq addedReq mergedReq inflight = +addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight = -- This assertion checks the pre-condition 'addNewFetchRequest' that all -- requested blocks are new. This is true irrespective of fetch-request @@ -300,7 +295,7 @@ addHeadersInFlight reqTime blockFetchSize oldReq addedReq mergedReq inflight = (\_ _ -> error "addHeadersInFlight: precondition violated") (peerFetchBlocksInFlight inflight) ( Map.fromList - [ (blockPoint header, defaultPeerFetchBlockInFlight reqTime) + [ (blockPoint header, PeerFetchBlockInFlight) | fragment <- fetchRequestFragments addedReq , header <- AF.toOldestFirst fragment ] ), @@ -460,7 +455,7 @@ data TraceFetchClientState header = -- only operation that grows the in-flight blocks, and is only used by the -- fetch decision logic thread. -- -addNewFetchRequest :: (MonadSTM m, HasHeader header, MonadMonotonicTime m) +addNewFetchRequest :: (MonadSTM m, HasHeader header) => Tracer m (TraceFetchClientState header) -> (header -> SizeInBytes) -> FetchRequest header @@ -473,7 +468,6 @@ addNewFetchRequest tracer blockFetchSize addedReq gsvs fetchClientInFlightVar, fetchClientStatusVar } = do - reqTime <- getMonotonicTime (inflight', currentStatus') <- atomically $ do -- Add a new fetch request, or extend or merge with the existing @@ -491,7 +485,7 @@ addNewFetchRequest tracer blockFetchSize addedReq gsvs -- Update our in-flight stats inflight <- readTVar fetchClientInFlightVar - let !inflight' = addHeadersInFlight reqTime blockFetchSize + let !inflight' = addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight writeTVar fetchClientInFlightVar inflight' diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 8578d56d806..d336c0fd33e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -101,8 +101,7 @@ iterateForever x0 m = go x0 where go x = m x >>= go fetchLogicIteration :: (Hashable peer, MonadSTM m, Ord peer, HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block, - MonadMonotonicTime m) + HeaderHash header ~ HeaderHash block) => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])] -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) -> FetchDecisionPolicy header @@ -216,7 +215,7 @@ fetchDecisionsForStateSnapshot -- request variables that are shared with the threads running the block fetch -- protocol with each peer. -- -fetchLogicIterationAct :: (MonadSTM m, HasHeader header, MonadMonotonicTime m) +fetchLogicIterationAct :: (MonadSTM m, HasHeader header) => Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) -> FetchDecisionPolicy header -> [(FetchDecision (FetchRequest header), From 01faa030d7509751a8898ab60d88a43abb9105ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 25 Jun 2024 19:18:37 +0200 Subject: [PATCH 038/136] The bulk sync decision function returns the actual request --- .../Ouroboros/Network/BlockFetch/Decision.hs | 20 ++++++++++------- .../Network/BlockFetch/Decision/BulkSync.hs | 22 ++++++++++++++----- 2 files changed, 28 insertions(+), 14 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index f80bc2cac93..6a7f68fe61e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -22,7 +22,10 @@ module Ouroboros.Network.BlockFetch.Decision , fetchRequestDecisions ) where +import Data.Bifunctor (Bifunctor(..)) import Data.Hashable +import Data.List (singleton) + import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder) @@ -69,11 +72,12 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo - peersOrder - = - fetchDecisionsBulkSync - fetchDecisionPolicy - currentChain - fetchedBlocks - fetchedMaxSlotNo - peersOrder + peersOrder = + uncurry (++) + . bimap (maybe [] (singleton . first Right)) (map (first Left)) + . fetchDecisionsBulkSync + fetchDecisionPolicy + currentChain + fetchedBlocks + fetchedMaxSlotNo + peersOrder diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 2841c5db117..db2ad97492d 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -16,7 +16,7 @@ import Data.Bifunctor (first, Bifunctor (..)) import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe, catMaybes) +import Data.Maybe (catMaybes) import Data.Ord (Down(Down)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) @@ -50,8 +50,11 @@ fetchDecisionsBulkSync :: PeersOrder peer -> -- | Association list of the candidate fragments and their associated peers. [(AnchoredFragment header, PeerInfo header peer extra)] -> - -- | Association list of the requests and their associated peers. - [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] + -- | Association list of the requests and their associated peers. There is at + -- most one accepted request; everything else is declined. + ( Maybe (FetchRequest header, PeerInfo header peer extra) + , [(FetchDecline, PeerInfo header peer extra)] + ) fetchDecisionsBulkSync fetchDecisionPolicy currentChain @@ -93,10 +96,17 @@ fetchDecisionsBulkSync thePeer thePeerCandidate - pure [(theDecision, thePeer)] + MaybeT $ + case theDecision of + Left reason -> tell [(reason, thePeer)] >> pure Nothing + Right theRequest -> pure $ Just (theRequest, thePeer) where - combineWithDeclined :: MaybeT (WithDeclined peer) [(FetchDecision a, peer)] -> [(FetchDecision a, peer)] - combineWithDeclined = uncurry (++) . bimap (fromMaybe []) (map (first Left)) . runWithDeclined . runMaybeT + combineWithDeclined :: + MaybeT (WithDeclined peer) (a, peer) -> + ( Maybe (a, peer), + [(FetchDecline, peer)] + ) + combineWithDeclined = runWithDeclined . runMaybeT -- FIXME: The 'FetchDeclineConcurrencyLimit' should only be used for -- 'FetchModeDeadline', and 'FetchModeBulkSync' should have its own reasons. From 55465ac45f47edf421abc1d60486994368a384dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 25 Jun 2024 20:20:24 +0200 Subject: [PATCH 039/136] Make `fetchDecisions` return a monadic action --- .../Ouroboros/Network/BlockFetch/Decision.hs | 40 +++++++++++-------- .../src/Ouroboros/Network/BlockFetch/State.hs | 7 ++-- 2 files changed, 28 insertions(+), 19 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 6a7f68fe61e..f631dfd916d 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -42,7 +42,8 @@ fetchDecisions :: (Ord peer, Hashable peer, HasHeader header, - HeaderHash header ~ HeaderHash block) + HeaderHash header ~ HeaderHash block, + Applicative m) => FetchDecisionPolicy header -> FetchMode -> AnchoredFragment header @@ -50,7 +51,7 @@ fetchDecisions -> MaxSlotNo -> PeersOrder peer -> [(AnchoredFragment header, PeerInfo header peer extra)] - -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] + -> m [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisions fetchDecisionPolicy @@ -59,12 +60,15 @@ fetchDecisions fetchedBlocks fetchedMaxSlotNo _peersOrder + candidatesAndPeers = - fetchDecisionsDeadline - fetchDecisionPolicy - currentChain - fetchedBlocks - fetchedMaxSlotNo + pure + $ fetchDecisionsDeadline + fetchDecisionPolicy + currentChain + fetchedBlocks + fetchedMaxSlotNo + candidatesAndPeers fetchDecisions fetchDecisionPolicy @@ -72,12 +76,16 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo - peersOrder = - uncurry (++) - . bimap (maybe [] (singleton . first Right)) (map (first Left)) - . fetchDecisionsBulkSync - fetchDecisionPolicy - currentChain - fetchedBlocks - fetchedMaxSlotNo - peersOrder + peersOrder + candidatesAndPeers = do + let (theDecision, declines) = + fetchDecisionsBulkSync + fetchDecisionPolicy + currentChain + fetchedBlocks + fetchedMaxSlotNo + peersOrder + candidatesAndPeers + pure $ + maybe [] (singleton . first Right) theDecision + ++ map (first Left) declines diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index d336c0fd33e..1c0ccd4277b 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -130,7 +130,7 @@ fetchLogicIteration decisionTracer clientStateTracer -- TODO: log the difference in the fingerprint that caused us to wake up -- Make all the fetch decisions - let decisions = fetchDecisionsForStateSnapshot + decisions <- fetchDecisionsForStateSnapshot fetchDecisionPolicy stateSnapshot @@ -167,10 +167,11 @@ fetchDecisionsForStateSnapshot :: (HasHeader header, HeaderHash header ~ HeaderHash block, Ord peer, - Hashable peer) + Hashable peer, + Applicative m) => FetchDecisionPolicy header -> FetchStateSnapshot peer header block m - -> [( FetchDecision (FetchRequest header), + -> m [( FetchDecision (FetchRequest header), PeerInfo header peer (FetchClientStateVars m header, peer) )] From 33afee7d03f2309bf6a8ca6f73f74771c1ddd8ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 25 Jun 2024 20:57:30 +0200 Subject: [PATCH 040/136] Update the peers order following the blockfetch decision --- .../Ouroboros/Network/BlockFetch/Decision.hs | 44 ++++++++++++++++--- .../src/Ouroboros/Network/BlockFetch/State.hs | 6 ++- 2 files changed, 43 insertions(+), 7 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index f631dfd916d..356e336367f 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -25,10 +25,11 @@ module Ouroboros.Network.BlockFetch.Decision import Data.Bifunctor (Bifunctor(..)) import Data.Hashable import Data.List (singleton) +import Data.Maybe (listToMaybe) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), @@ -43,13 +44,15 @@ fetchDecisions Hashable peer, HasHeader header, HeaderHash header ~ HeaderHash block, - Applicative m) + Monad m) => FetchDecisionPolicy header -> FetchMode -> AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo - -> PeersOrder peer + -> ( PeersOrder peer + , PeersOrder peer -> m () + ) -> [(AnchoredFragment header, PeerInfo header peer extra)] -> m [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] @@ -76,16 +79,47 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo - peersOrder + ( PeersOrder {peersOrderAll}, + writePeersOrder + ) candidatesAndPeers = do + -- Align the peers order with the actual peers; this consists in removing + -- all peers from the peers order that are not in the actual peers list and + -- adding at the end of the peers order all the actual peers that were not + -- there before. + let actualPeers = map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers + peersOrderAll' = + filter (`elem` actualPeers) peersOrderAll + ++ filter (`notElem` peersOrderAll) actualPeers + peersOrder' = PeersOrder peersOrderAll' + + -- FIXME: If ChainSel was starved, push the current peer to the end of the + -- peers order priority queue. + + -- Compute the actual block fetch decision. This contains only declines and + -- at most one request. 'theDecision' is therefore a 'Maybe'. let (theDecision, declines) = fetchDecisionsBulkSync fetchDecisionPolicy currentChain fetchedBlocks fetchedMaxSlotNo - peersOrder + peersOrder' candidatesAndPeers + + -- If the peer that is supposed to fetch the block is not the first in the + -- peers order, then we have changed focused peer. We move the new peer at + -- the beginning of the queue, but we do not push the other one away, + -- because it has not done anything wrong. + case theDecision of + Just (_, (_, _, _, thePeer, _)) + | Just thePeer /= listToMaybe peersOrderAll -> do + let peersOrder'' = PeersOrder $ thePeer : filter (/= thePeer) peersOrderAll' + -- FIXME: Record the current time as the first time we chose that + -- new peer. + writePeersOrder peersOrder'' + _ -> pure () + pure $ maybe [] (singleton . first Right) theDecision ++ map (first Left) declines diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 1c0ccd4277b..7dd68e74e99 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -168,7 +168,7 @@ fetchDecisionsForStateSnapshot HeaderHash header ~ HeaderHash block, Ord peer, Hashable peer, - Applicative m) + Monad m) => FetchDecisionPolicy header -> FetchStateSnapshot peer header block m -> m [( FetchDecision (FetchRequest header), @@ -199,7 +199,9 @@ fetchDecisionsForStateSnapshot fetchStateCurrentChain fetchStateFetchedBlocks fetchStateFetchedMaxSlotNo - fetchStatePeersOrder + ( fetchStatePeersOrder + , undefined + ) peerChainsAndPeerInfo where peerChainsAndPeerInfo = From 6587d1cadda9997a1596e4a9eadd3d9f6e1bccb3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 26 Jun 2024 12:30:16 +0200 Subject: [PATCH 041/136] Write the peers order and record the start time --- .../src/Ouroboros/Network/BlockFetch.hs | 66 ++---------------- .../Network/BlockFetch/ClientState.hs | 11 ++- .../Ouroboros/Network/BlockFetch/Decision.hs | 69 +++++++++++++------ .../Network/BlockFetch/Decision/BulkSync.hs | 5 +- .../src/Ouroboros/Network/BlockFetch/State.hs | 49 ++++++++----- 5 files changed, 96 insertions(+), 104 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index b69bf414ae7..78fd589d6b2 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -102,11 +102,8 @@ module Ouroboros.Network.BlockFetch ) where import Data.Hashable (Hashable) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map import Data.Void -import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked (StrictTVar, newTVarIO, readTVar, writeTVar) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI @@ -120,7 +117,6 @@ import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientPolicy (..), bracketSyncWithFetchClient, newFetchClientRegistry, readFetchClientsStateVars, readFetchClientsStatus, readPeerGSVs, setFetchClientContext) -import Ouroboros.Network.BlockFetch.ClientState (PeersOrder (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (BlockFetchConsensusInterface (..), FromConsensus (..), WhetherReceivingTentativeBlocks (..)) @@ -178,14 +174,12 @@ blockFetchLogic decisionTracer clientStateTracer setFetchClientContext registry clientStateTracer mkFetchClientPolicy - peersOrderVar <- newTVarIO $ PeersOrder [] - fetchLogicIterations decisionTracer clientStateTracer fetchDecisionPolicy fetchTriggerVariables - (fetchNonTriggerVariables peersOrderVar) - (reportBadPeer demoteCSJDynamo peersOrderVar) + fetchNonTriggerVariables + demoteCSJDynamo where mkFetchClientPolicy :: WhetherReceivingTentativeBlocks -> STM m (FetchClientPolicy header block m) mkFetchClientPolicy receivingTentativeBlocks = do @@ -219,62 +213,12 @@ blockFetchLogic decisionTracer clientStateTracer readStatePeerStatus = readFetchClientsStatus registry } - fetchNonTriggerVariables :: - StrictTVar m (PeersOrder addr) -> - FetchNonTriggerVariables addr header block m - fetchNonTriggerVariables peersOrderVar = + fetchNonTriggerVariables :: FetchNonTriggerVariables addr header block m + fetchNonTriggerVariables = FetchNonTriggerVariables { readStateFetchedBlocks = readFetchedBlocks, readStatePeerStateVars = readFetchClientsStateVars registry, readStatePeerGSVs = readPeerGSVs registry, readStateFetchMode = readFetchMode, - readStateFetchedMaxSlotNo = readFetchedMaxSlotNo, - readStatePeersOrder = readUpdatePeersOrder peersOrderVar readCandidateChains + readStateFetchedMaxSlotNo = readFetchedMaxSlotNo } - --- | Read the current peers order from the TVar, update it according to the --- current peers, and return the updated order. -readUpdatePeersOrder :: - ( MonadSTM m, - Eq addr - ) => - -- | The TVar containing the current order of peers. - StrictTVar m (PeersOrder addr) -> - -- | An STM action to read all the current peers. This can for instance be - -- 'readCandidateChains'. - STM m (Map addr whatever) -> - STM m (PeersOrder addr) -readUpdatePeersOrder peersOrderVar readPeers = do - PeersOrder{peersOrderAll} - <- readTVar peersOrderVar - currentPeers <- Map.keys <$> readPeers - let peersOrderAll' = - filter (`elem` currentPeers) peersOrderAll - ++ filter (`notElem` peersOrderAll) currentPeers - peersOrder' = PeersOrder peersOrderAll' - writeTVar peersOrderVar peersOrder' - pure peersOrder' - --- | Report a peer as a bad peer. This pushes the peer to the end of the peers --- order and demotes it from the dynamo role in ChainSync Jumping (CSJ) in the --- consensus layer. -reportBadPeer :: - ( MonadSTM m, - Eq peer - ) => - -- | An STM action to demote a peer from the dynamo role in ChainSync Jumping - -- (CSJ) in the consensus layer. - (peer -> m ()) -> - -- | The TVar containing the current order of peers. - StrictTVar m (PeersOrder peer) -> - -- | The peer that we know is a bad peer (e.g. because it has not respected - -- our syncing BlockFetch timeouts). - peer -> - m () -reportBadPeer demoteCSJDynamo peersOrderVar peer = do - atomically $ do - PeersOrder {peersOrderAll} <- readTVar peersOrderVar - let peersOrderAll' = filter (/= peer) peersOrderAll ++ [peer] - peersOrder' = PeersOrder peersOrderAll' - writeTVar peersOrderVar peersOrder' - demoteCSJDynamo peer diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index d1efcd69190..e4d542343cb 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -800,6 +800,15 @@ tryReadTMergeVar :: MonadSTM m -> STM m (Maybe a) tryReadTMergeVar (TMergeVar v) = tryReadTMVar v +-- | The order of peers for bulk sync fetch decisions. +-- +-- We could merge the current peer into the list of others, but we keep them +-- separate to make sure that we always consider it separately. data PeersOrder peer = PeersOrder - { peersOrderAll :: [peer] + { peersOrderOthers :: [peer] + -- ^ All the other peers, from most preferred to least preferred. + , peersOrderCurrent :: Maybe peer + -- ^ The current peer that we are talking to. + , peersOrderStart :: Time + -- ^ The time at which we started talking to that peer. } diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 356e336367f..3b57de2962f 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -25,7 +25,6 @@ module Ouroboros.Network.BlockFetch.Decision import Data.Bifunctor (Bifunctor(..)) import Data.Hashable import Data.List (singleton) -import Data.Maybe (listToMaybe) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block @@ -38,13 +37,14 @@ import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), P import Ouroboros.Network.BlockFetch.Decision.Deadline (fetchDecisionsDeadline, prioritisePeerChains, fetchRequestDecisions) import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSync) +import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..)) fetchDecisions - :: (Ord peer, + :: forall peer header block m extra. + (Ord peer, Hashable peer, HasHeader header, - HeaderHash header ~ HeaderHash block, - Monad m) + HeaderHash header ~ HeaderHash block, MonadMonotonicTime m) => FetchDecisionPolicy header -> FetchMode -> AnchoredFragment header @@ -52,6 +52,7 @@ fetchDecisions -> MaxSlotNo -> ( PeersOrder peer , PeersOrder peer -> m () + , peer -> m () ) -> [(AnchoredFragment header, PeerInfo header peer extra)] -> m [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] @@ -79,22 +80,22 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo - ( PeersOrder {peersOrderAll}, - writePeersOrder + ( peersOrder0, + writePeersOrder, + _demoteCSJDynamo ) candidatesAndPeers = do -- Align the peers order with the actual peers; this consists in removing -- all peers from the peers order that are not in the actual peers list and -- adding at the end of the peers order all the actual peers that were not -- there before. - let actualPeers = map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers - peersOrderAll' = - filter (`elem` actualPeers) peersOrderAll - ++ filter (`notElem` peersOrderAll) actualPeers - peersOrder' = PeersOrder peersOrderAll' + let peersOrder@PeersOrder {peersOrderCurrent, peersOrderOthers} = + alignPeersOrderWithActualPeers + peersOrder0 + (map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers) -- FIXME: If ChainSel was starved, push the current peer to the end of the - -- peers order priority queue. + -- peers order priority queue and demote CSJ dynamo. -- Compute the actual block fetch decision. This contains only declines and -- at most one request. 'theDecision' is therefore a 'Maybe'. @@ -104,22 +105,46 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo - peersOrder' + peersOrder candidatesAndPeers - -- If the peer that is supposed to fetch the block is not the first in the - -- peers order, then we have changed focused peer. We move the new peer at - -- the beginning of the queue, but we do not push the other one away, - -- because it has not done anything wrong. + -- If the peer that is supposed to fetch the block is not the current one in + -- the peers order, then we have shifted our focus: we make the new peer our + -- current one and we put back the previous current peer at the beginning of + -- the queue; not the end, because it has not done anything wrong. case theDecision of Just (_, (_, _, _, thePeer, _)) - | Just thePeer /= listToMaybe peersOrderAll -> do - let peersOrder'' = PeersOrder $ thePeer : filter (/= thePeer) peersOrderAll' - -- FIXME: Record the current time as the first time we chose that - -- new peer. - writePeersOrder peersOrder'' + | Just thePeer /= peersOrderCurrent -> do + peersOrderStart' <- getMonotonicTime + let peersOrder' = + PeersOrder + { peersOrderCurrent = Just thePeer, + peersOrderStart = peersOrderStart', + peersOrderOthers = mcons peersOrderCurrent (filter (/= thePeer) peersOrderOthers) + } + writePeersOrder peersOrder' _ -> pure () pure $ maybe [] (singleton . first Right) theDecision ++ map (first Left) declines + where + alignPeersOrderWithActualPeers :: PeersOrder peer -> [peer] -> PeersOrder peer + alignPeersOrderWithActualPeers + PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} + actualPeers = + let peersOrderCurrent' = case peersOrderCurrent of + Just peersOrderCurrent_ | peersOrderCurrent_ `elem` actualPeers -> peersOrderCurrent + _ -> Nothing + peersOrderOthers' = + filter (`elem` actualPeers) peersOrderOthers + ++ filter (`notElem` peersOrderOthers) actualPeers + in PeersOrder + { peersOrderCurrent = peersOrderCurrent', + peersOrderOthers = peersOrderOthers', + peersOrderStart + } + +mcons :: Maybe a -> [a] -> [a] +mcons Nothing xs = xs +mcons (Just x) xs = x : xs diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index db2ad97492d..aa011204017 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -234,9 +234,12 @@ selectThePeer let peersOrdered = [ (candidate, peerInfo) | (candidate, peerInfo@(_, _, _, peer, _)) <- peers, - peer' <- peersOrderAll peersOrder, + peer' <- mcons (peersOrderCurrent peersOrder) (peersOrderOthers peersOrder), peer == peer' ] + where + mcons Nothing xs = xs + mcons (Just x) xs = x : xs -- Return the first peer in that order, and decline all the ones that were -- not already declined. diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 7dd68e74e99..eedaae2029b 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -24,6 +24,7 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Void +import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked (newTVarIO, StrictTVar, readTVarIO, writeTVar) import Control.Exception (assert) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime.SI @@ -37,7 +38,7 @@ import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchClientStateVars (..), FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..), TraceFetchClientState (..), TraceLabelPeer (..), addNewFetchRequest, - readFetchClientState, PeersOrder) + readFetchClientState, PeersOrder (..)) import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecisionPolicy (..), FetchDecline (..), FetchMode (..), PeerInfo, fetchDecisions) @@ -58,13 +59,19 @@ fetchLogicIterations -> FetchDecisionPolicy header -> FetchTriggerVariables peer header m -> FetchNonTriggerVariables peer header block m - -> (peer -> m ()) -- ^ Report a peer as bad with respect to BlockFetch. + -> (peer -> m ()) -- ^ Action to call to demote the dynamo of ChainSync jumping. -> m Void fetchLogicIterations decisionTracer clientStateTracer fetchDecisionPolicy fetchTriggerVariables fetchNonTriggerVariables - _reportBadPeer = + demoteCSJDynamo = do + + peersOrderVar <- newTVarIO $ PeersOrder { + peersOrderCurrent = Nothing, + peersOrderStart = Time 0, + peersOrderOthers = [] + } iterateForever initialFetchStateFingerprint $ \stateFingerprint -> do @@ -79,6 +86,7 @@ fetchLogicIterations decisionTracer clientStateTracer fetchTriggerVariables fetchNonTriggerVariables stateFingerprint + (peersOrderVar, demoteCSJDynamo) end <- getMonotonicTime let delta = diffTime end start -- Limit decision is made once every decisionLoopInterval. @@ -101,19 +109,22 @@ iterateForever x0 m = go x0 where go x = m x >>= go fetchLogicIteration :: (Hashable peer, MonadSTM m, Ord peer, HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) + HeaderHash header ~ HeaderHash block, + MonadMonotonicTime m) => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])] -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) -> FetchDecisionPolicy header -> FetchTriggerVariables peer header m -> FetchNonTriggerVariables peer header block m -> FetchStateFingerprint peer header block + -> (StrictTVar m (PeersOrder peer), peer -> m ()) -> m (FetchStateFingerprint peer header block) fetchLogicIteration decisionTracer clientStateTracer fetchDecisionPolicy fetchTriggerVariables fetchNonTriggerVariables - stateFingerprint = do + stateFingerprint + (peersOrderVar, demoteCSJDynamo) = do -- Gather a snapshot of all the state we need. (stateSnapshot, stateFingerprint') <- @@ -122,6 +133,7 @@ fetchLogicIteration decisionTracer clientStateTracer fetchTriggerVariables fetchNonTriggerVariables stateFingerprint + peersOrder <- readTVarIO peersOrderVar -- TODO: allow for boring PeerFetchStatusBusy transitions where we go round -- again rather than re-evaluating everything. @@ -133,6 +145,7 @@ fetchLogicIteration decisionTracer clientStateTracer decisions <- fetchDecisionsForStateSnapshot fetchDecisionPolicy stateSnapshot + (peersOrder, atomically . writeTVar peersOrderVar, demoteCSJDynamo) -- If we want to trace timings, we can do it here after forcing: -- _ <- evaluate (force decisions) @@ -168,9 +181,13 @@ fetchDecisionsForStateSnapshot HeaderHash header ~ HeaderHash block, Ord peer, Hashable peer, - Monad m) + MonadMonotonicTime m) => FetchDecisionPolicy header -> FetchStateSnapshot peer header block m + -> ( PeersOrder peer + , PeersOrder peer -> m () + , peer -> m () + ) -> m [( FetchDecision (FetchRequest header), PeerInfo header peer (FetchClientStateVars m header, peer) )] @@ -184,9 +201,9 @@ fetchDecisionsForStateSnapshot fetchStatePeerGSVs, fetchStateFetchedBlocks, fetchStateFetchedMaxSlotNo, - fetchStateFetchMode, - fetchStatePeersOrder - } = + fetchStateFetchMode + } + peersOrderHandlers = assert ( Map.keysSet fetchStatePeerChains `Set.isSubsetOf` Map.keysSet fetchStatePeerStates) $ @@ -199,9 +216,7 @@ fetchDecisionsForStateSnapshot fetchStateCurrentChain fetchStateFetchedBlocks fetchStateFetchedMaxSlotNo - ( fetchStatePeersOrder - , undefined - ) + peersOrderHandlers peerChainsAndPeerInfo where peerChainsAndPeerInfo = @@ -262,8 +277,7 @@ data FetchNonTriggerVariables peer header block m = FetchNonTriggerVariables { readStatePeerStateVars :: STM m (Map peer (FetchClientStateVars m header)), readStatePeerGSVs :: STM m (Map peer PeerGSV), readStateFetchMode :: STM m FetchMode, - readStateFetchedMaxSlotNo :: STM m MaxSlotNo, - readStatePeersOrder :: STM m (PeersOrder peer) + readStateFetchedMaxSlotNo :: STM m MaxSlotNo } @@ -306,8 +320,7 @@ data FetchStateSnapshot peer header block m = FetchStateSnapshot { fetchStatePeerGSVs :: Map peer PeerGSV, fetchStateFetchedBlocks :: Point block -> Bool, fetchStateFetchMode :: FetchMode, - fetchStateFetchedMaxSlotNo :: MaxSlotNo, - fetchStatePeersOrder :: PeersOrder peer + fetchStateFetchedMaxSlotNo :: MaxSlotNo } readStateVariables :: (MonadSTM m, Eq peer, @@ -344,7 +357,6 @@ readStateVariables FetchTriggerVariables{..} fetchStateFetchedBlocks <- readStateFetchedBlocks fetchStateFetchMode <- readStateFetchMode fetchStateFetchedMaxSlotNo <- readStateFetchedMaxSlotNo - fetchStatePeersOrder <- readStatePeersOrder -- Construct the overall snapshot of the state let fetchStateSnapshot = @@ -355,8 +367,7 @@ readStateVariables FetchTriggerVariables{..} fetchStatePeerGSVs, fetchStateFetchedBlocks, fetchStateFetchMode, - fetchStateFetchedMaxSlotNo, - fetchStatePeersOrder + fetchStateFetchedMaxSlotNo } return (fetchStateSnapshot, fetchStateFingerprint') From 11549051b9435844ce9e97f01acc272a9bdf334c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 26 Jun 2024 12:51:09 +0200 Subject: [PATCH 042/136] Check last ChainSel starvation --- .../src/Ouroboros/Network/BlockFetch.hs | 3 +- .../Ouroboros/Network/BlockFetch/Decision.hs | 53 ++++++++++++++----- .../src/Ouroboros/Network/BlockFetch/State.hs | 14 +++-- 3 files changed, 51 insertions(+), 19 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index 78fd589d6b2..bccdd4661b2 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -220,5 +220,6 @@ blockFetchLogic decisionTracer clientStateTracer readStatePeerStateVars = readFetchClientsStateVars registry, readStatePeerGSVs = readPeerGSVs registry, readStateFetchMode = readFetchMode, - readStateFetchedMaxSlotNo = readFetchedMaxSlotNo + readStateFetchedMaxSlotNo = readFetchedMaxSlotNo, + readStateLastChainSelStarvation = lastChainSelStarvation } diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 3b57de2962f..1b49c522068 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -25,6 +25,9 @@ module Ouroboros.Network.BlockFetch.Decision import Data.Bifunctor (Bifunctor(..)) import Data.Hashable import Data.List (singleton) +import Data.Foldable (traverse_) +import Data.Function ((&)) +import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..), addTime, DiffTime, Time (..)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block @@ -37,7 +40,6 @@ import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), P import Ouroboros.Network.BlockFetch.Decision.Deadline (fetchDecisionsDeadline, prioritisePeerChains, fetchRequestDecisions) import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSync) -import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..)) fetchDecisions :: forall peer header block m extra. @@ -50,6 +52,7 @@ fetchDecisions -> AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo + -> Time -- ^ Last time ChainSel was starved -> ( PeersOrder peer , PeersOrder peer -> m () , peer -> m () @@ -63,7 +66,8 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo - _peersOrder + _lastChainSelStarvation + _peersOrderHandlers candidatesAndPeers = pure @@ -80,22 +84,24 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo + lastChainSelStarvation ( peersOrder0, writePeersOrder, - _demoteCSJDynamo + demoteCSJDynamo ) candidatesAndPeers = do - -- Align the peers order with the actual peers; this consists in removing - -- all peers from the peers order that are not in the actual peers list and - -- adding at the end of the peers order all the actual peers that were not - -- there before. - let peersOrder@PeersOrder {peersOrderCurrent, peersOrderOthers} = - alignPeersOrderWithActualPeers - peersOrder0 - (map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers) - - -- FIXME: If ChainSel was starved, push the current peer to the end of the - -- peers order priority queue and demote CSJ dynamo. + peersOrder@PeersOrder {peersOrderCurrent, peersOrderOthers} <- + -- Align the peers order with the actual peers; this consists in removing + -- all peers from the peers order that are not in the actual peers list and + -- adding at the end of the peers order all the actual peers that were not + -- there before. + alignPeersOrderWithActualPeers + peersOrder0 + (map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers) + -- If the chain selection has been starved recently, that is after the + -- current peer started (and a grace period), then the current peer is bad. + -- We push it at the end of the queue and demote it from CSJ dynamo. + & checkLastChainSelStarvation -- Compute the actual block fetch decision. This contains only declines and -- at most one request. 'theDecision' is therefore a 'Maybe'. @@ -145,6 +151,25 @@ fetchDecisions peersOrderStart } + checkLastChainSelStarvation :: PeersOrder peer -> m (PeersOrder peer) + checkLastChainSelStarvation + peersOrder@PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = + if lastChainSelStarvation <= addTime (10 :: DiffTime) peersOrderStart + then pure peersOrder + else do + let peersOrder' = + PeersOrder + { peersOrderCurrent = Nothing, + peersOrderOthers = msnoc peersOrderOthers peersOrderCurrent, + peersOrderStart + } + traverse_ demoteCSJDynamo peersOrderCurrent + pure peersOrder' + mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs mcons (Just x) xs = x : xs + +msnoc :: [a] -> Maybe a -> [a] +msnoc xs Nothing = xs +msnoc xs (Just x) = xs ++ [x] diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index eedaae2029b..2a227c161d2 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -201,7 +201,8 @@ fetchDecisionsForStateSnapshot fetchStatePeerGSVs, fetchStateFetchedBlocks, fetchStateFetchedMaxSlotNo, - fetchStateFetchMode + fetchStateFetchMode, + fetchStateLastChainSelStarvation } peersOrderHandlers = assert ( Map.keysSet fetchStatePeerChains @@ -216,6 +217,7 @@ fetchDecisionsForStateSnapshot fetchStateCurrentChain fetchStateFetchedBlocks fetchStateFetchedMaxSlotNo + fetchStateLastChainSelStarvation peersOrderHandlers peerChainsAndPeerInfo where @@ -277,7 +279,8 @@ data FetchNonTriggerVariables peer header block m = FetchNonTriggerVariables { readStatePeerStateVars :: STM m (Map peer (FetchClientStateVars m header)), readStatePeerGSVs :: STM m (Map peer PeerGSV), readStateFetchMode :: STM m FetchMode, - readStateFetchedMaxSlotNo :: STM m MaxSlotNo + readStateFetchedMaxSlotNo :: STM m MaxSlotNo, + readStateLastChainSelStarvation :: STM m Time } @@ -320,7 +323,8 @@ data FetchStateSnapshot peer header block m = FetchStateSnapshot { fetchStatePeerGSVs :: Map peer PeerGSV, fetchStateFetchedBlocks :: Point block -> Bool, fetchStateFetchMode :: FetchMode, - fetchStateFetchedMaxSlotNo :: MaxSlotNo + fetchStateFetchedMaxSlotNo :: MaxSlotNo, + fetchStateLastChainSelStarvation :: Time } readStateVariables :: (MonadSTM m, Eq peer, @@ -357,6 +361,7 @@ readStateVariables FetchTriggerVariables{..} fetchStateFetchedBlocks <- readStateFetchedBlocks fetchStateFetchMode <- readStateFetchMode fetchStateFetchedMaxSlotNo <- readStateFetchedMaxSlotNo + fetchStateLastChainSelStarvation <- readStateLastChainSelStarvation -- Construct the overall snapshot of the state let fetchStateSnapshot = @@ -367,7 +372,8 @@ readStateVariables FetchTriggerVariables{..} fetchStatePeerGSVs, fetchStateFetchedBlocks, fetchStateFetchMode, - fetchStateFetchedMaxSlotNo + fetchStateFetchedMaxSlotNo, + fetchStateLastChainSelStarvation } return (fetchStateSnapshot, fetchStateFingerprint') From 3c4aae7a464b036626d3e08541f3baf73c84e1b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 26 Jun 2024 15:08:33 +0200 Subject: [PATCH 043/136] Make grace period very small for testing purposes --- ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 1b49c522068..6679dbabdf6 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -154,7 +154,7 @@ fetchDecisions checkLastChainSelStarvation :: PeersOrder peer -> m (PeersOrder peer) checkLastChainSelStarvation peersOrder@PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = - if lastChainSelStarvation <= addTime (10 :: DiffTime) peersOrderStart + if lastChainSelStarvation <= addTime (1 :: DiffTime) peersOrderStart then pure peersOrder else do let peersOrder' = From dfe0abd6dc405ffd9a78f746e9ccc484c4bc063b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 27 Jun 2024 09:21:14 +0000 Subject: [PATCH 044/136] Get more information from ChainSel starvation --- .../Network/BlockFetch/ConsensusInterface.hs | 21 ++++++++++++++++--- .../src/Ouroboros/Network/BlockFetch.hs | 2 +- .../Ouroboros/Network/BlockFetch/Decision.hs | 19 ++++++++++------- .../src/Ouroboros/Network/BlockFetch/State.hs | 13 ++++++------ 4 files changed, 37 insertions(+), 18 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index 10ae86ed97e..60235a43723 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -1,11 +1,14 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} module Ouroboros.Network.BlockFetch.ConsensusInterface ( FetchMode (..) , BlockFetchConsensusInterface (..) , WhetherReceivingTentativeBlocks (..) , FromConsensus (..) + , ChainSelStarvation (..) ) where import Control.Monad.Class.MonadSTM @@ -14,6 +17,8 @@ import Control.Monad.Class.MonadTime.SI (Time) import Data.Map.Strict (Map) import GHC.Stack (HasCallStack) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block @@ -154,9 +159,9 @@ data BlockFetchConsensusInterface peer header block m = -- WARNING: Same as 'headerForgeUTCTime'. blockForgeUTCTime :: FromConsensus block -> STM m UTCTime, - -- | The last time that the Chain Selection pipeline was starved, that is - -- it tried to pop a block but there wasn't any. - lastChainSelStarvation :: STM m Time, + -- | Information on the ChainSel starvation status; whether it is ongoing + -- or has ended recently. Needed by the bulk sync decision logic. + readChainSelStarvation :: STM m ChainSelStarvation, -- | Action to inform CSJ that the given peer has not been performing -- adequately with respect to BlockFetch, and that it should be demoted @@ -172,6 +177,16 @@ data WhetherReceivingTentativeBlocks = ReceivingTentativeBlocks | NotReceivingTentativeBlocks +-- | Whether ChainSel is starved or has been recently. +-- +-- The bulk sync fetch decision logic needs to decide whether the current +-- focused peer has starved ChainSel recently. This datatype is used to +-- represent this piece of information. +data ChainSelStarvation + = ChainSelStarvationOngoing + | ChainSelStarvationEndedAt Time + deriving (Eq, Show, NoThunks, Generic) + {------------------------------------------------------------------------------- Syntactic indicator of key precondition about Consensus time conversions -------------------------------------------------------------------------------} diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index bccdd4661b2..e5f525454d5 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -221,5 +221,5 @@ blockFetchLogic decisionTracer clientStateTracer readStatePeerGSVs = readPeerGSVs registry, readStateFetchMode = readFetchMode, readStateFetchedMaxSlotNo = readFetchedMaxSlotNo, - readStateLastChainSelStarvation = lastChainSelStarvation + readStateChainSelStarvation = readChainSelStarvation } diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 6679dbabdf6..9f2c6025d63 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -27,12 +27,12 @@ import Data.Hashable import Data.List (singleton) import Data.Foldable (traverse_) import Data.Function ((&)) -import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..), addTime, DiffTime, Time (..)) +import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..), addTime, DiffTime) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..)) -import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..), ChainSelStarvation) import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), filterPlausibleCandidates, filterNotAlreadyFetched, filterNotAlreadyInFlightWithPeer, @@ -40,6 +40,7 @@ import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), P import Ouroboros.Network.BlockFetch.Decision.Deadline (fetchDecisionsDeadline, prioritisePeerChains, fetchRequestDecisions) import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSync) +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) fetchDecisions :: forall peer header block m extra. @@ -52,7 +53,7 @@ fetchDecisions -> AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo - -> Time -- ^ Last time ChainSel was starved + -> ChainSelStarvation -> ( PeersOrder peer , PeersOrder peer -> m () , peer -> m () @@ -66,7 +67,7 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo - _lastChainSelStarvation + _chainSelStarvation _peersOrderHandlers candidatesAndPeers = @@ -84,7 +85,7 @@ fetchDecisions currentChain fetchedBlocks fetchedMaxSlotNo - lastChainSelStarvation + chainSelStarvation ( peersOrder0, writePeersOrder, demoteCSJDynamo @@ -154,9 +155,11 @@ fetchDecisions checkLastChainSelStarvation :: PeersOrder peer -> m (PeersOrder peer) checkLastChainSelStarvation peersOrder@PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = - if lastChainSelStarvation <= addTime (1 :: DiffTime) peersOrderStart - then pure peersOrder - else do + case chainSelStarvation of + ChainSelStarvationEndedAt time + | time < addTime (1 :: DiffTime) peersOrderStart -> + pure peersOrder + _ -> do let peersOrder' = PeersOrder { peersOrderCurrent = Nothing, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 2a227c161d2..ecb2193a83e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -43,6 +43,7 @@ import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecisionPolicy (..), FetchDecline (..), FetchMode (..), PeerInfo, fetchDecisions) import Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation) fetchLogicIterations @@ -202,7 +203,7 @@ fetchDecisionsForStateSnapshot fetchStateFetchedBlocks, fetchStateFetchedMaxSlotNo, fetchStateFetchMode, - fetchStateLastChainSelStarvation + fetchStateChainSelStarvation } peersOrderHandlers = assert ( Map.keysSet fetchStatePeerChains @@ -217,7 +218,7 @@ fetchDecisionsForStateSnapshot fetchStateCurrentChain fetchStateFetchedBlocks fetchStateFetchedMaxSlotNo - fetchStateLastChainSelStarvation + fetchStateChainSelStarvation peersOrderHandlers peerChainsAndPeerInfo where @@ -280,7 +281,7 @@ data FetchNonTriggerVariables peer header block m = FetchNonTriggerVariables { readStatePeerGSVs :: STM m (Map peer PeerGSV), readStateFetchMode :: STM m FetchMode, readStateFetchedMaxSlotNo :: STM m MaxSlotNo, - readStateLastChainSelStarvation :: STM m Time + readStateChainSelStarvation :: STM m ChainSelStarvation } @@ -324,7 +325,7 @@ data FetchStateSnapshot peer header block m = FetchStateSnapshot { fetchStateFetchedBlocks :: Point block -> Bool, fetchStateFetchMode :: FetchMode, fetchStateFetchedMaxSlotNo :: MaxSlotNo, - fetchStateLastChainSelStarvation :: Time + fetchStateChainSelStarvation :: ChainSelStarvation } readStateVariables :: (MonadSTM m, Eq peer, @@ -361,7 +362,7 @@ readStateVariables FetchTriggerVariables{..} fetchStateFetchedBlocks <- readStateFetchedBlocks fetchStateFetchMode <- readStateFetchMode fetchStateFetchedMaxSlotNo <- readStateFetchedMaxSlotNo - fetchStateLastChainSelStarvation <- readStateLastChainSelStarvation + fetchStateChainSelStarvation <- readStateChainSelStarvation -- Construct the overall snapshot of the state let fetchStateSnapshot = @@ -373,7 +374,7 @@ readStateVariables FetchTriggerVariables{..} fetchStateFetchedBlocks, fetchStateFetchMode, fetchStateFetchedMaxSlotNo, - fetchStateLastChainSelStarvation + fetchStateChainSelStarvation } return (fetchStateSnapshot, fetchStateFingerprint') From f32d17159a0ed62dc9fc918aad5ea4885e4b65e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 27 Jun 2024 16:41:14 +0000 Subject: [PATCH 045/136] Export `mcons` and `msnoc` close to `PeersOrder` --- .../src/Ouroboros/Network/BlockFetch/ClientState.hs | 10 ++++++++++ .../src/Ouroboros/Network/BlockFetch/Decision.hs | 10 +--------- .../Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 5 +---- 3 files changed, 12 insertions(+), 13 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index e4d542343cb..a9d3bb4cd55 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -35,6 +35,8 @@ module Ouroboros.Network.BlockFetch.ClientState , WhetherReceivingTentativeBlocks (..) , defaultPeerFetchBlockInFlight , PeersOrder(..) + , mcons + , msnoc ) where import Data.List (foldl') @@ -812,3 +814,11 @@ data PeersOrder peer = PeersOrder , peersOrderStart :: Time -- ^ The time at which we started talking to that peer. } + +mcons :: Maybe a -> [a] -> [a] +mcons Nothing xs = xs +mcons (Just x) xs = x : xs + +msnoc :: [a] -> Maybe a -> [a] +msnoc xs Nothing = xs +msnoc xs (Just x) = xs ++ [x] diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 9f2c6025d63..6a18039943e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -31,7 +31,7 @@ import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..), addTime, DiffTi import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), msnoc, mcons) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..), ChainSelStarvation) import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), @@ -168,11 +168,3 @@ fetchDecisions } traverse_ demoteCSJDynamo peersOrderCurrent pure peersOrder' - -mcons :: Maybe a -> [a] -> [a] -mcons Nothing xs = xs -mcons (Just x) xs = x : xs - -msnoc :: [a] -> Maybe a -> [a] -msnoc xs Nothing = xs -msnoc xs (Just x) = xs ++ [x] diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index aa011204017..3fd88f4b391 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -22,7 +22,7 @@ import Data.Ord (Down(Down)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), mcons) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) @@ -237,9 +237,6 @@ selectThePeer peer' <- mcons (peersOrderCurrent peersOrder) (peersOrderOthers peersOrder), peer == peer' ] - where - mcons Nothing xs = xs - mcons (Just x) xs = x : xs -- Return the first peer in that order, and decline all the ones that were -- not already declined. From fda748dfc9b42ac4decacb97dcd610e721b31938 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 28 Jun 2024 14:12:01 +0000 Subject: [PATCH 046/136] More efficient implementation of `trimFragmentsToCandidate` --- .../Network/BlockFetch/Decision/BulkSync.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 3fd88f4b391..3e96ad4db89 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -16,7 +16,7 @@ import Data.Bifunctor (first, Bifunctor (..)) import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, mapMaybe) import Data.Ord (Down(Down)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) @@ -304,10 +304,13 @@ fetchTheCandidate where trimFragmentsToCandidate candidate fragments = let trimmedFragments = - -- FIXME: This can most definitely be improved considering that the - -- property to be in `candidate` is monotonic. - concatMap - (AF.filter (flip AF.withinFragmentBounds (getChainSuffix candidate) . blockPoint)) + mapMaybe + ( \fragment -> + -- 'candidate' is anchored at the immutable tip, so we don't + -- need to look for something more complicated than this. + (\(_, prefix, _, _) -> prefix) + <$> AF.intersect (getChainSuffix candidate) fragment + ) fragments in if null trimmedFragments then Left FetchDeclineAlreadyFetched From cc689fbc42961ac3bdc4d634c7590ecb106a5aaf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 3 Jul 2024 12:00:40 +0200 Subject: [PATCH 047/136] Some fixes --- ouroboros-network/demo/chain-sync.hs | 7 ++++++- ouroboros-network/ouroboros-network.cabal | 1 + .../Ouroboros/Network/BlockFetch/Examples.hs | 6 +++++- .../sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs | 4 ++-- .../Test/Ouroboros/Network/Diffusion/Node.hs | 8 ++++++-- 5 files changed, 20 insertions(+), 6 deletions(-) diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 4c7acd3935a..a97140aa759 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -31,6 +31,7 @@ import Control.Concurrent.Async import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception import Control.Monad (when) +import Control.Monad.Class.MonadTime.SI (Time (..)) import Control.Tracer import System.Directory @@ -75,6 +76,7 @@ import Ouroboros.Network.Protocol.BlockFetch.Type qualified as BlockFetch import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.Client import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientRegistry (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) import Ouroboros.Network.DeltaQ (defaultGSV) @@ -440,7 +442,10 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do blockMatchesHeader = \_ _ -> True, headerForgeUTCTime, - blockForgeUTCTime = headerForgeUTCTime . fmap blockHeader + blockForgeUTCTime = headerForgeUTCTime . fmap blockHeader, + + readChainSelStarvation = pure (ChainSelStarvationEndedAt (Time 0)), + demoteCSJDynamo = \_ -> pure () } where plausibleCandidateChain cur candidate = diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 33470e378ef..d52d378b9ec 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -341,6 +341,7 @@ executable demo-chain-sync contra-tracer, + si-timers, typed-protocols, strict-stm, ouroboros-network-api, diff --git a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs index fb9c0bee85c..d63ad4bc89c 100644 --- a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -44,6 +44,7 @@ import Ouroboros.Network.ControlMessage (ControlMessageSTM) import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.Client +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) import Ouroboros.Network.Channel import Ouroboros.Network.DeltaQ import Ouroboros.Network.Driver @@ -293,7 +294,10 @@ sampleBlockFetchPolicy1 headerFieldsForgeUTCTime blockHeap currentChain candidat blockMatchesHeader = \_ _ -> True, headerForgeUTCTime = headerFieldsForgeUTCTime, - blockForgeUTCTime = headerFieldsForgeUTCTime + blockForgeUTCTime = headerFieldsForgeUTCTime, + + readChainSelStarvation = pure (ChainSelStarvationEndedAt (Time 0)), + demoteCSJDynamo = \_ -> pure () } where plausibleCandidateChain cur candidate = diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs index 7a241ceecf8..60990c6cfeb 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs @@ -373,7 +373,7 @@ tracePropertyClientStateSanity es = saneStateValues PeerFetchInFlight {..} status = -- Here we know the fixed dummy block size so we know exactly what -- the bytes in flight should be. - Set.size peerFetchBlocksInFlight * 2000 + Map.size peerFetchBlocksInFlight * 2000 == fromIntegral peerFetchBytesInFlight && case status of @@ -382,7 +382,7 @@ tracePropertyClientStateSanity es = _ -> False -- not used in this test && if peerFetchReqsInFlight == 0 - then Set.null peerFetchBlocksInFlight + then Map.null peerFetchBlocksInFlight else True diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs index 2b79d3d0e9c..a86de30e9e6 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -38,7 +38,7 @@ import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadEvaluate, MonadMask, MonadThrow, SomeException) -import Control.Monad.Class.MonadTime.SI (DiffTime, MonadTime) +import Control.Monad.Class.MonadTime.SI (DiffTime, MonadTime, Time (..)) import Control.Monad.Class.MonadTimer.SI (MonadDelay, MonadTimer) import Control.Monad.Fix (MonadFix) import Control.Tracer (Tracer (..), nullTracer) @@ -66,6 +66,7 @@ import Ouroboros.Network.AnchoredFragment qualified as AF import Ouroboros.Network.Block (MaxSlotNo (..), maxSlotNoFromWithOrigin, pointSlot) import Ouroboros.Network.BlockFetch +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) import Ouroboros.Network.ConnectionManager.Types (DataFlow (..)) import Ouroboros.Network.Diffusion qualified as Diff import Ouroboros.Network.Diffusion.P2P qualified as Diff.P2P @@ -323,7 +324,10 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = blockMatchesHeader = \_ _ -> True, headerForgeUTCTime, - blockForgeUTCTime = headerForgeUTCTime . fmap blockHeader + blockForgeUTCTime = headerForgeUTCTime . fmap blockHeader, + + readChainSelStarvation = pure (ChainSelStarvationEndedAt (Time 0)), + demoteCSJDynamo = \_ -> pure () } where plausibleCandidateChain cur candidate = From d63b00abc6efc74ef00c3ca94b3a155e75cfc169 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 3 Jul 2024 15:15:22 +0200 Subject: [PATCH 048/136] Some comments and types --- .../Network/BlockFetch/Decision/BulkSync.hs | 27 ++++++++++++++----- 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 3e96ad4db89..f8872a2532e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | This module contains the part of the block fetch decisions process that is -- specific to the bulk sync mode. @@ -44,16 +45,21 @@ fetchDecisionsBulkSync :: Eq peer ) => FetchDecisionPolicy header -> + -- | The current chain, anchored at the immutable tip. AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo -> PeersOrder peer -> -- | Association list of the candidate fragments and their associated peers. + -- The candidate fragments are anchored in the current chain (not necessarily + -- at the tip). [(AnchoredFragment header, PeerInfo header peer extra)] -> -- | Association list of the requests and their associated peers. There is at - -- most one accepted request; everything else is declined. - ( Maybe (FetchRequest header, PeerInfo header peer extra) - , [(FetchDecline, PeerInfo header peer extra)] + -- most one accepted request; everything else is declined. Morally, this is a + -- map from peers to @'FetchDecision' ('FetchRequest' header)@ with at most + -- one @'FetchRequest' header@. + ( Maybe (FetchRequest header, PeerInfo header peer extra), + [(FetchDecline, PeerInfo header peer extra)] ) fetchDecisionsBulkSync fetchDecisionPolicy @@ -65,7 +71,12 @@ fetchDecisionsBulkSync -- Step 1: Select the candidate to sync from. This already eliminates peers -- that have an implausible candidate. It returns the remaining candidates -- (with their corresponding peer) as suffixes of the immutable tip. - (theCandidate, candidatesAndPeers') <- + -- + -- FIXME: 'ChainSuffix' is supposed to represent fragments that fork off the + -- selection, and we use it the wrong way here? + ( theCandidate :: ChainSuffix header, + candidatesAndPeers' :: [(ChainSuffix header, PeerInfo header peer extra)] + ) <- MaybeT $ selectTheCandidate fetchDecisionPolicy @@ -75,7 +86,9 @@ fetchDecisionsBulkSync -- Step 2: Select the peer to sync from. This eliminates peers that cannot -- serve a reasonable batch of the candidate, then chooses the peer to sync -- from, then again declines the others. - (thePeerCandidate, thePeer) <- + ( thePeerCandidate :: ChainSuffix header, + thePeer :: PeerInfo header peer extra + ) <- MaybeT $ selectThePeer fetchDecisionPolicy @@ -96,6 +109,8 @@ fetchDecisionsBulkSync thePeer thePeerCandidate + -- FIXME: 'fetchTheCandidate' should also return a @WithDeclined (Maybe + -- ...)@. MaybeT $ case theDecision of Left reason -> tell [(reason, thePeer)] >> pure Nothing @@ -247,7 +262,7 @@ selectThePeer return $ Just (thePeerCandidate, thePeer) where checkRequestInCandidate :: - (HasHeader header) => ChainSuffix header -> FetchRequest header -> FetchDecision () + ChainSuffix header -> FetchRequest header -> FetchDecision () checkRequestInCandidate candidate request = if all isSubfragmentOfCandidate $ fetchRequestFragments request then pure () From 354fec99534de40721970716e1cb47e2aff38c41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 5 Jul 2024 14:19:11 +0200 Subject: [PATCH 049/136] [TRYOUT] Get rid of some `tell`s --- .../Network/BlockFetch/Decision/BulkSync.hs | 24 ++++++++++++------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index f8872a2532e..45b8caa408f 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -10,7 +10,6 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync ) where -import Control.Monad (filterM) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) @@ -236,13 +235,12 @@ selectThePeer -- For each peer, check whether its candidate contains the gross request -- in its entirety, otherwise decline it. peers <- - filterM - ( \(candidate, peer) -> - case checkRequestInCandidate candidate =<< grossRequest of - Left reason -> tell [(reason, peer)] >> pure False - Right () -> pure True - ) - candidates + tellLeftsFirst $ + map + ( first $ \candidate -> do + checkRequestInCandidate candidate =<< grossRequest + pure candidate ) + candidates -- Order the peers according to the peer order that we have been given, -- then separate between declined peers and the others. @@ -330,3 +328,13 @@ fetchTheCandidate in if null trimmedFragments then Left FetchDeclineAlreadyFetched else Right trimmedFragments + +tellLeftsFirst :: [(Either a b, c)] -> Writer [(a, c)] [(b, c)] +tellLeftsFirst xs = + let (lefts, rights) = partitionEithersFirst xs + in tell lefts >> pure rights + +partitionEithersFirst :: [(Either a b, c)] -> ([(a, c)], [(b, c)]) +partitionEithersFirst [] = ([], []) +partitionEithersFirst ((Left a, c) : xs) = first ((a, c) :) (partitionEithersFirst xs) +partitionEithersFirst ((Right b, c) : xs) = second ((b, c) :) (partitionEithersFirst xs) From 1b8072f17c242da8746510c6adbdc7f13ff75096 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 5 Jul 2024 14:20:14 +0200 Subject: [PATCH 050/136] Grace period of 10 seconds --- ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 6a18039943e..eefd878f292 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -157,7 +157,7 @@ fetchDecisions peersOrder@PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = case chainSelStarvation of ChainSelStarvationEndedAt time - | time < addTime (1 :: DiffTime) peersOrderStart -> + | time < addTime (10 :: DiffTime) peersOrderStart -> pure peersOrder _ -> do let peersOrder' = From c8b8cc51c3bbea58f2b385bff81dd3c32c6457a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 5 Jul 2024 14:29:34 +0200 Subject: [PATCH 051/136] Make grace period configurable --- ouroboros-network/demo/chain-sync.hs | 3 ++- .../sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs | 6 ++++-- .../sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs | 3 ++- ouroboros-network/src/Ouroboros/Network/BlockFetch.hs | 7 ++++++- .../src/Ouroboros/Network/BlockFetch/Decision.hs | 6 +++--- .../src/Ouroboros/Network/BlockFetch/Decision/Common.hs | 1 + .../src/Ouroboros/Network/Diffusion/Configuration.hs | 1 + 7 files changed, 19 insertions(+), 8 deletions(-) diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index a97140aa759..f702484ace5 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -515,7 +515,8 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, - bfcSalt = 0 + bfcSalt = 0, + bfcBulkSyncGracePeriod = 10 -- seconds }) >> return () diff --git a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs index d63ad4bc89c..1a1a8d08489 100644 --- a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -139,7 +139,8 @@ blockFetchExample0 decisionTracer clientStateTracer clientMsgTracer bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, - bfcSalt = 0 + bfcSalt = 0, + bfcBulkSyncGracePeriod = 10 -- seconds }) >> return () @@ -248,7 +249,8 @@ blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, - bfcSalt = 0 + bfcSalt = 0, + bfcBulkSyncGracePeriod = 10 -- seconds }) >> return () diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs index a86de30e9e6..faa38b73255 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -295,7 +295,8 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, - bfcSalt = 0 + bfcSalt = 0, + bfcBulkSyncGracePeriod = 10 -- seconds }) blockFetchPolicy :: NodeKernel BlockHeader Block s m diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index e5f525454d5..9bb3ca63cf9 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -141,7 +141,11 @@ data BlockFetchConfiguration = bfcDecisionLoopInterval :: !DiffTime, -- | Salt used when comparing peers - bfcSalt :: !Int + bfcSalt :: !Int, + + -- | Grace period when starting to talk to a peer in bulk sync mode + -- during which it is fine if the chain selection gets starved. + bfcBulkSyncGracePeriod :: !DiffTime } deriving (Show) @@ -199,6 +203,7 @@ blockFetchLogic decisionTracer clientStateTracer maxConcurrencyDeadline = bfcMaxConcurrencyDeadline, decisionLoopInterval = bfcDecisionLoopInterval, peerSalt = bfcSalt, + bulkSyncGracePeriod = bfcBulkSyncGracePeriod, plausibleCandidateChain, compareCandidateChains, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index eefd878f292..3fcab657f7c 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -80,7 +80,7 @@ fetchDecisions candidatesAndPeers fetchDecisions - fetchDecisionPolicy + fetchDecisionPolicy@FetchDecisionPolicy {bulkSyncGracePeriod} FetchModeBulkSync currentChain fetchedBlocks @@ -157,8 +157,8 @@ fetchDecisions peersOrder@PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = case chainSelStarvation of ChainSelStarvationEndedAt time - | time < addTime (10 :: DiffTime) peersOrderStart -> - pure peersOrder + | time < addTime bulkSyncGracePeriod peersOrderStart -> + pure peersOrder _ -> do let peersOrder' = PeersOrder diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index fd1a579bc6a..bbe8edf7772 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -46,6 +46,7 @@ data FetchDecisionPolicy header = FetchDecisionPolicy { maxConcurrencyDeadline :: Word, decisionLoopInterval :: DiffTime, peerSalt :: Int, + bulkSyncGracePeriod :: DiffTime, plausibleCandidateChain :: HasCallStack => AnchoredFragment header diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index c71e30ddddf..119ea20e08b 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -95,6 +95,7 @@ defaultBlockFetchConfiguration bfcSalt = bfcMaxConcurrencyDeadline = 1, bfcMaxRequestsInflight = fromIntegral $ blockFetchPipeliningMax defaultMiniProtocolParameters, bfcDecisionLoopInterval = 0.01, -- 10ms + bfcBulkSyncGracePeriod = 10, -- seconds bfcSalt } defaultChainSyncTimeout :: IO ChainSyncTimeout From b3650eec22e1f299f9fe7c7cc5c5c40fcbf61282 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 5 Jul 2024 14:57:18 +0200 Subject: [PATCH 052/136] Fix handling of ongoing starvation --- .../src/Ouroboros/Network/BlockFetch/Decision.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 3fcab657f7c..ab4e053bceb 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -27,7 +27,7 @@ import Data.Hashable import Data.List (singleton) import Data.Foldable (traverse_) import Data.Function ((&)) -import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..), addTime, DiffTime) +import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..), addTime) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block @@ -154,12 +154,13 @@ fetchDecisions checkLastChainSelStarvation :: PeersOrder peer -> m (PeersOrder peer) checkLastChainSelStarvation - peersOrder@PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = - case chainSelStarvation of - ChainSelStarvationEndedAt time - | time < addTime bulkSyncGracePeriod peersOrderStart -> - pure peersOrder - _ -> do + peersOrder@PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = do + lastStarvationTime <- case chainSelStarvation of + ChainSelStarvationEndedAt time -> pure time + ChainSelStarvationOngoing -> getMonotonicTime + if lastStarvationTime < addTime bulkSyncGracePeriod peersOrderStart + then pure peersOrder + else do let peersOrder' = PeersOrder { peersOrderCurrent = Nothing, From 0308e0c98b7e69150e5905c7ea214e87600e5d98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 8 Jul 2024 11:20:36 +0200 Subject: [PATCH 053/136] Make `fetchTheCandidate` also return a Writer Maybe --- .../Network/BlockFetch/Decision/BulkSync.hs | 72 +++++++++---------- 1 file changed, 34 insertions(+), 38 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 45b8caa408f..7b5b86ab05a 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -51,7 +51,7 @@ fetchDecisionsBulkSync :: PeersOrder peer -> -- | Association list of the candidate fragments and their associated peers. -- The candidate fragments are anchored in the current chain (not necessarily - -- at the tip). + -- at the tip; and not necessarily forking off immediately). [(AnchoredFragment header, PeerInfo header peer extra)] -> -- | Association list of the requests and their associated peers. There is at -- most one accepted request; everything else is declined. Morally, this is a @@ -70,9 +70,6 @@ fetchDecisionsBulkSync -- Step 1: Select the candidate to sync from. This already eliminates peers -- that have an implausible candidate. It returns the remaining candidates -- (with their corresponding peer) as suffixes of the immutable tip. - -- - -- FIXME: 'ChainSuffix' is supposed to represent fragments that fork off the - -- selection, and we use it the wrong way here? ( theCandidate :: ChainSuffix header, candidatesAndPeers' :: [(ChainSuffix header, PeerInfo header peer extra)] ) <- @@ -99,21 +96,14 @@ fetchDecisionsBulkSync -- Step 3: Fetch the candidate from the selected peer, potentially declining -- it (eg. if the peer is already too busy). - let theDecision = - fetchTheCandidate - fetchDecisionPolicy - fetchedBlocks - fetchedMaxSlotNo - theCandidate - thePeer - thePeerCandidate - - -- FIXME: 'fetchTheCandidate' should also return a @WithDeclined (Maybe - -- ...)@. MaybeT $ - case theDecision of - Left reason -> tell [(reason, thePeer)] >> pure Nothing - Right theRequest -> pure $ Just (theRequest, thePeer) + fetchTheCandidate + fetchDecisionPolicy + fetchedBlocks + fetchedMaxSlotNo + theCandidate + thePeer + thePeerCandidate where combineWithDeclined :: MaybeT (WithDeclined peer) (a, peer) -> @@ -287,33 +277,39 @@ fetchTheCandidate :: PeerInfo header peer extra -> -- | Its candidate fragment as suffix of the immutable tip. ChainSuffix header -> - FetchDecision (FetchRequest header) + WithDeclined + (PeerInfo header peer extra) + (Maybe (FetchRequest header, PeerInfo header peer extra)) fetchTheCandidate fetchDecisionPolicy fetchedBlocks fetchedMaxSlotNo theCandidate - (status, inflight, gsvs, _, _) - thePeerCandidate = do - -- Keep blocks that have not already been downloaded or that are not - -- already in-flight with this peer. - fragments <- - filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate - >>= filterNotAlreadyInFlightWithPeer inflight + thePeer@(status, inflight, gsvs, _, _) + thePeerCandidate = + let theDecision = do + -- Keep blocks that have not already been downloaded or that are not + -- already in-flight with this peer. + fragments <- + filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate + >>= filterNotAlreadyInFlightWithPeer inflight - -- Trim the fragments to the peer's candidate, keeping only blocks that - -- they may actually serve. - trimmedFragments <- trimFragmentsToCandidate thePeerCandidate (snd fragments) + -- Trim the fragments to the peer's candidate, keeping only blocks that + -- they may actually serve. + trimmedFragments <- trimFragmentsToCandidate thePeerCandidate (snd fragments) - -- Try to create a request for those fragments. - fetchRequestDecision - fetchDecisionPolicy - FetchModeBulkSync - 0 -- bypass all concurrency limits. REVIEW: is this really what we want? - (calculatePeerFetchInFlightLimits gsvs) - inflight - status - (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. + -- Try to create a request for those fragments. + fetchRequestDecision + fetchDecisionPolicy + FetchModeBulkSync + 0 -- bypass all concurrency limits. REVIEW: is this really what we want? + (calculatePeerFetchInFlightLimits gsvs) + inflight + status + (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. + in case theDecision of + Left reason -> tell [(reason, thePeer)] >> pure Nothing + Right theRequest -> pure $ Just (theRequest, thePeer) where trimFragmentsToCandidate candidate fragments = let trimmedFragments = From 1b717f23f09eccff66f6118f6f27aaf5ed7766a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 8 Jul 2024 11:20:58 +0200 Subject: [PATCH 054/136] Switch to CPS Writer --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 7b5b86ab05a..3367182ca24 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -11,7 +11,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( ) where import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) -import Control.Monad.Writer (Writer, runWriter, MonadWriter (tell)) +import Control.Monad.Writer.CPS (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) From 2ba5078c2f54369a59af573136e656e2c1f40650 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 8 Jul 2024 11:37:06 +0200 Subject: [PATCH 055/136] Revert "[TRYOUT] Get rid of some `tell`s" This reverts commit 354fec99534de40721970716e1cb47e2aff38c41. --- .../Network/BlockFetch/Decision/BulkSync.hs | 24 +++++++------------ 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 3367182ca24..ffe0d04214d 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -10,6 +10,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSync ) where +import Control.Monad (filterM) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.CPS (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) @@ -225,12 +226,13 @@ selectThePeer -- For each peer, check whether its candidate contains the gross request -- in its entirety, otherwise decline it. peers <- - tellLeftsFirst $ - map - ( first $ \candidate -> do - checkRequestInCandidate candidate =<< grossRequest - pure candidate ) - candidates + filterM + ( \(candidate, peer) -> + case checkRequestInCandidate candidate =<< grossRequest of + Left reason -> tell [(reason, peer)] >> pure False + Right () -> pure True + ) + candidates -- Order the peers according to the peer order that we have been given, -- then separate between declined peers and the others. @@ -324,13 +326,3 @@ fetchTheCandidate in if null trimmedFragments then Left FetchDeclineAlreadyFetched else Right trimmedFragments - -tellLeftsFirst :: [(Either a b, c)] -> Writer [(a, c)] [(b, c)] -tellLeftsFirst xs = - let (lefts, rights) = partitionEithersFirst xs - in tell lefts >> pure rights - -partitionEithersFirst :: [(Either a b, c)] -> ([(a, c)], [(b, c)]) -partitionEithersFirst [] = ([], []) -partitionEithersFirst ((Left a, c) : xs) = first ((a, c) :) (partitionEithersFirst xs) -partitionEithersFirst ((Right b, c) : xs) = second ((b, c) :) (partitionEithersFirst xs) From 1b8a232aaca7ac80fbb47213b1a74803fc5d4564 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 8 Jul 2024 11:38:52 +0200 Subject: [PATCH 056/136] Avoid `Writer [a]` --- .../Network/BlockFetch/Decision/BulkSync.hs | 29 ++++++++++++++----- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index ffe0d04214d..223406ef8c4 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -14,6 +14,7 @@ import Control.Monad (filterM) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.CPS (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) +import Data.Foldable (toList) import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE @@ -32,9 +33,23 @@ import Ouroboros.Network.BlockFetch.Decision.Common -- arises, we should move the interesting piece of code to 'Decision.Common'. -- This is to be done on demand. -type WithDeclined peer = Writer [(FetchDecline, peer)] +-- | A trivial foldable data structure with a 'Semigroup' instance that +-- concatenates in @O(1)@. Only meant for short-term use, followed by one fold. +data ListConcat a = List [a] | Concat (ListConcat a) (ListConcat a) -runWithDeclined :: WithDeclined peer a -> (a, [(FetchDecline, peer)]) +instance Semigroup (ListConcat a) where + (<>) = Concat + +instance Monoid (ListConcat a) where + mempty = List [] + +instance Foldable ListConcat where + foldMap f (List xs) = foldMap f xs + foldMap f (Concat x y) = foldMap f x <> foldMap f y + +type WithDeclined peer = Writer (ListConcat (FetchDecline, peer)) + +runWithDeclined :: WithDeclined peer a -> (a, ListConcat (FetchDecline, peer)) runWithDeclined = runWriter -- | Given a list of candidate fragments and their associated peers, choose what @@ -111,7 +126,7 @@ fetchDecisionsBulkSync ( Maybe (a, peer), [(FetchDecline, peer)] ) - combineWithDeclined = runWithDeclined . runMaybeT + combineWithDeclined = second toList . runWithDeclined . runMaybeT -- FIXME: The 'FetchDeclineConcurrencyLimit' should only be used for -- 'FetchModeDeadline', and 'FetchModeBulkSync' should have its own reasons. @@ -159,7 +174,7 @@ selectTheCandidate <$> traverse ( \(decision, peer) -> case decision of - Left reason -> tell [(reason, peer)] >> pure Nothing + Left reason -> tell (List [(reason, peer)]) >> pure Nothing Right candidate -> pure $ Just (candidate, peer) ) decisions @@ -229,7 +244,7 @@ selectThePeer filterM ( \(candidate, peer) -> case checkRequestInCandidate candidate =<< grossRequest of - Left reason -> tell [(reason, peer)] >> pure False + Left reason -> tell (List [(reason, peer)]) >> pure False Right () -> pure True ) candidates @@ -248,7 +263,7 @@ selectThePeer case peersOrdered of [] -> return Nothing (thePeerCandidate, thePeer) : otherPeers -> do - tell $ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers + tell $ List $ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers return $ Just (thePeerCandidate, thePeer) where checkRequestInCandidate :: @@ -310,7 +325,7 @@ fetchTheCandidate status (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. in case theDecision of - Left reason -> tell [(reason, thePeer)] >> pure Nothing + Left reason -> tell (List [(reason, thePeer)]) >> pure Nothing Right theRequest -> pure $ Just (theRequest, thePeer) where trimFragmentsToCandidate candidate fragments = From e58a48f5893e2892e52fd6f0ea8b98ec9af69e5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 9 Jul 2024 12:08:07 +0200 Subject: [PATCH 057/136] More performant (hopefully) `toList` --- .../Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 223406ef8c4..e94d7f12793 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -14,7 +14,6 @@ import Control.Monad (filterM) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.CPS (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) -import Data.Foldable (toList) import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE @@ -43,9 +42,11 @@ instance Semigroup (ListConcat a) where instance Monoid (ListConcat a) where mempty = List [] -instance Foldable ListConcat where - foldMap f (List xs) = foldMap f xs - foldMap f (Concat x y) = foldMap f x <> foldMap f y +listConcatToList :: ListConcat a -> [a] +listConcatToList = flip go [] + where + go (List xs) acc = xs ++ acc + go (Concat x y) acc = go x (go y acc) type WithDeclined peer = Writer (ListConcat (FetchDecline, peer)) @@ -126,7 +127,7 @@ fetchDecisionsBulkSync ( Maybe (a, peer), [(FetchDecline, peer)] ) - combineWithDeclined = second toList . runWithDeclined . runMaybeT + combineWithDeclined = second listConcatToList . runWithDeclined . runMaybeT -- FIXME: The 'FetchDeclineConcurrencyLimit' should only be used for -- 'FetchModeDeadline', and 'FetchModeBulkSync' should have its own reasons. From dd92744c6f1de1fd683f555d5d7b56505c68f812 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 8 Jul 2024 12:21:10 +0200 Subject: [PATCH 058/136] Mark blocks as ignored when demoting peer --- .../Network/BlockFetch/ClientState.hs | 9 +++++++-- .../Ouroboros/Network/BlockFetch/Decision.hs | 9 +++++---- .../src/Ouroboros/Network/BlockFetch/State.hs | 20 +++++++++++++++++-- 3 files changed, 30 insertions(+), 8 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index a9d3bb4cd55..3720c2ecdf8 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -238,10 +238,15 @@ data PeerFetchInFlight header = PeerFetchInFlight { -- | Information associated to a block in flight. data PeerFetchBlockInFlight = PeerFetchBlockInFlight + { -- | The block fetch decision logic might decide to ignore a block that is + -- in flight. It will only be ignored when taking decisions, by it can of + -- course not be ignored when computing the actual request. + peerFetchBlocksInFlightIgnoredByLogic :: !Bool + } deriving (Eq, Show) defaultPeerFetchBlockInFlight :: PeerFetchBlockInFlight -defaultPeerFetchBlockInFlight = PeerFetchBlockInFlight +defaultPeerFetchBlockInFlight = PeerFetchBlockInFlight False initialPeerFetchInFlight :: PeerFetchInFlight header initialPeerFetchInFlight = @@ -297,7 +302,7 @@ addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight = (\_ _ -> error "addHeadersInFlight: precondition violated") (peerFetchBlocksInFlight inflight) ( Map.fromList - [ (blockPoint header, PeerFetchBlockInFlight) + [ (blockPoint header, defaultPeerFetchBlockInFlight) | fragment <- fetchRequestFragments addedReq , header <- AF.toOldestFirst fragment ] ), diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index ab4e053bceb..6545a012105 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -88,7 +88,7 @@ fetchDecisions chainSelStarvation ( peersOrder0, writePeersOrder, - demoteCSJDynamo + demoteCSJDynamoAndIgnoreInflightBlocks ) candidatesAndPeers = do peersOrder@PeersOrder {peersOrderCurrent, peersOrderOthers} <- @@ -100,8 +100,9 @@ fetchDecisions peersOrder0 (map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers) -- If the chain selection has been starved recently, that is after the - -- current peer started (and a grace period), then the current peer is bad. - -- We push it at the end of the queue and demote it from CSJ dynamo. + -- current peer started (and a grace period), then the current peer is + -- bad. We push it at the end of the queue, demote it from CSJ dynamo, + -- and ignore its in-flight blocks for the future. & checkLastChainSelStarvation -- Compute the actual block fetch decision. This contains only declines and @@ -167,5 +168,5 @@ fetchDecisions peersOrderOthers = msnoc peersOrderOthers peersOrderCurrent, peersOrderStart } - traverse_ demoteCSJDynamo peersOrderCurrent + traverse_ demoteCSJDynamoAndIgnoreInflightBlocks peersOrderCurrent pure peersOrder' diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index ecb2193a83e..2aa52117f4b 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -38,12 +38,13 @@ import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchClientStateVars (..), FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..), TraceFetchClientState (..), TraceLabelPeer (..), addNewFetchRequest, - readFetchClientState, PeersOrder (..)) + readFetchClientState, PeersOrder (..), PeerFetchBlockInFlight (..)) import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecisionPolicy (..), FetchDecline (..), FetchMode (..), PeerInfo, fetchDecisions) import Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation) +import Control.Concurrent.Class.MonadSTM.Strict.TVar (modifyTVar) fetchLogicIterations @@ -146,7 +147,9 @@ fetchLogicIteration decisionTracer clientStateTracer decisions <- fetchDecisionsForStateSnapshot fetchDecisionPolicy stateSnapshot - (peersOrder, atomically . writeTVar peersOrderVar, demoteCSJDynamo) + (peersOrder, + atomically . writeTVar peersOrderVar, + demoteCSJDynamoAndIgnoreInflightBlocks) -- If we want to trace timings, we can do it here after forcing: -- _ <- evaluate (force decisions) @@ -174,6 +177,19 @@ fetchLogicIteration decisionTracer clientStateTracer | headers <- headerss , header <- AF.toOldestFirst headers ] + demoteCSJDynamoAndIgnoreInflightBlocks peer = do + demoteCSJDynamo peer + atomically $ do + peerStateVars <- readStatePeerStateVars fetchNonTriggerVariables + case Map.lookup peer peerStateVars of + Nothing -> return () + Just peerStateVar -> + modifyTVar (fetchClientInFlightVar peerStateVar) $ \pfif -> + pfif + { peerFetchBlocksInFlight = + fmap (const (PeerFetchBlockInFlight True)) (peerFetchBlocksInFlight pfif) + } + -- | Do a bit of rearranging of data before calling 'fetchDecisions' to do the -- real work. -- From 37622e273a91ac5e446d59edc6a6d2fbc7ea61bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 9 Jul 2024 13:26:27 +0200 Subject: [PATCH 059/136] Ignore blocks when choosing the peer to sync from --- .../Network/BlockFetch/Decision/BulkSync.hs | 60 ++++++++++++++++--- 1 file changed, 51 insertions(+), 9 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index e94d7f12793..972e0117e58 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -14,16 +14,21 @@ import Control.Monad (filterM) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.CPS (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) +import Data.Foldable (foldl') import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, mapMaybe) +import qualified Data.Set as Set import Data.Ord (Down(Down)) +import Cardano.Prelude (guard) + import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), mcons) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), mcons, PeerFetchBlockInFlight (..), PeerFetchStatus (..), PeerFetchInFlight (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) @@ -219,24 +224,26 @@ selectThePeer -- Filter out from the chosen candidate fragment the blocks that have -- already been downloaded, but keep the blocks that have a request in -- flight. - let fragments = - snd - <$> filterNotAlreadyFetched - fetchedBlocks - fetchedMaxSlotNo - theCandidate + let (fragments :: FetchDecision (CandidateFragments header)) = + filterNotAlreadyFetched + fetchedBlocks + fetchedMaxSlotNo + theCandidate + >>= filterNotAlreadyInFlightWithAnyPeerNonIgnored + candidates - -- Create a fetch request for the blocks in question The request is made + -- Create a fetch request for the blocks in question. The request is made -- to fit in 1MB but ignores everything else. It is gross in that sense. -- It will only be used to choose the peer to fetch from, but we will -- later craft a more refined request for that peer. - let grossRequest = + let (grossRequest :: FetchDecision (FetchRequest header)) = selectBlocksUpToLimits blockFetchSize 0 -- number of request in flight maxBound -- maximum number of requests in flight 0 -- bytes in flight (1024 * 1024) -- maximum bytes in flight; one megabyte + . snd <$> fragments -- For each peer, check whether its candidate contains the gross request @@ -342,3 +349,38 @@ fetchTheCandidate in if null trimmedFragments then Left FetchDeclineAlreadyFetched else Right trimmedFragments + +filterNotAlreadyInFlightWithAnyPeerNonIgnored :: + (HasHeader header) => + [(ChainSuffix header, PeerInfo header peer extra)] -> + CandidateFragments header -> + FetchDecision (CandidateFragments header) +filterNotAlreadyInFlightWithAnyPeerNonIgnored candidates theCandidate = do + let theFragments = + concatMap + ( filterWithMaxSlotNo + notAlreadyInFlightNonIgnored + maxSlotNoInFlightWithPeers + ) + (snd theCandidate) + guard (not (null theFragments)) ?! FetchDeclineInFlightOtherPeer + return $ (fst theCandidate, theFragments) + where + notAlreadyInFlightNonIgnored b = + blockPoint b `Set.notMember` blocksInFlightWithPeersNonIgnored + -- All the blocks that are already in-flight with all peers and not ignored. + blocksInFlightWithPeersNonIgnored = + Set.unions + [ case status of + PeerFetchStatusShutdown -> Set.empty + PeerFetchStatusStarting -> Set.empty + PeerFetchStatusAberrant -> Set.empty + _other -> Map.keysSet $ Map.filter (\(PeerFetchBlockInFlight b) -> not b) $ peerFetchBlocksInFlight inflight + | (_, (status, inflight, _, _, _)) <- candidates + ] + -- The highest slot number that is or has been in flight for any peer. + maxSlotNoInFlightWithPeers = + foldl' + max + NoMaxSlotNo + [peerFetchMaxSlotNo inflight | (_, (_, inflight, _, _, _)) <- candidates] From 85d9cc765061c3407140b7ee2b5d832528b78e99 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 9 Jul 2024 15:06:03 +0200 Subject: [PATCH 060/136] Fix duplication in peers order --- ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 6545a012105..67ace6b9e5c 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -146,7 +146,7 @@ fetchDecisions _ -> Nothing peersOrderOthers' = filter (`elem` actualPeers) peersOrderOthers - ++ filter (`notElem` peersOrderOthers) actualPeers + ++ filter (\peer -> peer `notElem` peersOrderOthers && Just peer /= peersOrderCurrent) actualPeers in PeersOrder { peersOrderCurrent = peersOrderCurrent', peersOrderOthers = peersOrderOthers', From 8ab406297e8a58f3e841ba4cf800fb84578511b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 9 Jul 2024 22:00:57 +0200 Subject: [PATCH 061/136] Also ignore blocks in flight by other peers in actual request, and code refactoring --- .../Network/BlockFetch/Decision/BulkSync.hs | 61 +++++++------------ 1 file changed, 21 insertions(+), 40 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 972e0117e58..6d04802854b 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -101,7 +101,15 @@ fetchDecisionsBulkSync currentChain candidatesAndPeers - -- Step 2: Select the peer to sync from. This eliminates peers that cannot + -- Step 2: Filter out from the chosen candidate fragment the blocks that + -- have already been downloaded, or that have a request in flight (except + -- for the requests in flight that are ignored). + let (theFragments :: FetchDecision (CandidateFragments header)) = + pure theCandidate + >>= filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo + >>= filterNotAlreadyInFlightWithAnyPeerNonIgnored candidatesAndPeers + + -- Step 3: Select the peer to sync from. This eliminates peers that cannot -- serve a reasonable batch of the candidate, then chooses the peer to sync -- from, then again declines the others. ( thePeerCandidate :: ChainSuffix header, @@ -110,20 +118,16 @@ fetchDecisionsBulkSync MaybeT $ selectThePeer fetchDecisionPolicy - fetchedBlocks - fetchedMaxSlotNo peersOrder - theCandidate + theFragments candidatesAndPeers' - -- Step 3: Fetch the candidate from the selected peer, potentially declining + -- Step 4: Fetch the candidate from the selected peer, potentially declining -- it (eg. if the peer is already too busy). MaybeT $ fetchTheCandidate fetchDecisionPolicy - fetchedBlocks - fetchedMaxSlotNo - theCandidate + theFragments thePeer thePeerCandidate where @@ -196,18 +200,15 @@ selectTheCandidate -- -- PRECONDITION: The set of peers must be included in the peer order queue. selectThePeer :: - forall header block peer extra. + forall header peer extra. ( HasHeader header, - HeaderHash header ~ HeaderHash block, Eq peer ) => FetchDecisionPolicy header -> - (Point block -> Bool) -> - MaxSlotNo -> PeersOrder peer -> -- | The candidate fragment that we have selected to sync from, as suffix of -- the immutable tip. - ChainSuffix header -> + FetchDecision (CandidateFragments header) -> -- | Association list of candidate fragments (as suffixes of the immutable -- tip) and their associated peers. [(ChainSuffix header, PeerInfo header peer extra)] -> @@ -216,22 +217,9 @@ selectThePeer :: (Maybe (ChainSuffix header, PeerInfo header peer extra)) selectThePeer FetchDecisionPolicy {blockFetchSize} - fetchedBlocks - fetchedMaxSlotNo peersOrder - theCandidate + theFragments candidates = do - -- Filter out from the chosen candidate fragment the blocks that have - -- already been downloaded, but keep the blocks that have a request in - -- flight. - let (fragments :: FetchDecision (CandidateFragments header)) = - filterNotAlreadyFetched - fetchedBlocks - fetchedMaxSlotNo - theCandidate - >>= filterNotAlreadyInFlightWithAnyPeerNonIgnored - candidates - -- Create a fetch request for the blocks in question. The request is made -- to fit in 1MB but ignores everything else. It is gross in that sense. -- It will only be used to choose the peer to fetch from, but we will @@ -244,7 +232,7 @@ selectThePeer 0 -- bytes in flight (1024 * 1024) -- maximum bytes in flight; one megabyte . snd - <$> fragments + <$> theFragments -- For each peer, check whether its candidate contains the gross request -- in its entirety, otherwise decline it. @@ -289,15 +277,12 @@ selectThePeer -- specific peer. We might take the 'FetchDecision' to decline the request, but -- only for “good” reasons, eg. if the peer is already too busy. fetchTheCandidate :: - ( HasHeader header, - HeaderHash header ~ HeaderHash block + ( HasHeader header ) => FetchDecisionPolicy header -> - (Point block -> Bool) -> - MaxSlotNo -> -- | The candidate fragment that we have selected to sync from, as suffix of -- the immutable tip. - ChainSuffix header -> + FetchDecision (CandidateFragments header) -> -- | The peer that we have selected to sync from. PeerInfo header peer extra -> -- | Its candidate fragment as suffix of the immutable tip. @@ -307,17 +292,13 @@ fetchTheCandidate :: (Maybe (FetchRequest header, PeerInfo header peer extra)) fetchTheCandidate fetchDecisionPolicy - fetchedBlocks - fetchedMaxSlotNo - theCandidate + theFragments thePeer@(status, inflight, gsvs, _, _) thePeerCandidate = let theDecision = do -- Keep blocks that have not already been downloaded or that are not -- already in-flight with this peer. - fragments <- - filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate - >>= filterNotAlreadyInFlightWithPeer inflight + fragments <- filterNotAlreadyInFlightWithPeer inflight =<< theFragments -- Trim the fragments to the peer's candidate, keeping only blocks that -- they may actually serve. @@ -352,7 +333,7 @@ fetchTheCandidate filterNotAlreadyInFlightWithAnyPeerNonIgnored :: (HasHeader header) => - [(ChainSuffix header, PeerInfo header peer extra)] -> + [(any, PeerInfo header peer extra)] -> CandidateFragments header -> FetchDecision (CandidateFragments header) filterNotAlreadyInFlightWithAnyPeerNonIgnored candidates theCandidate = do From e475726b489f4756dd55626a39c679c895352045 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Tue, 9 Jul 2024 22:15:44 +0200 Subject: [PATCH 062/136] Code cleanup --- .../Ouroboros/Network/BlockFetch/Decision.hs | 29 ++++++++++--------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 67ace6b9e5c..f10934cf10e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -91,7 +91,7 @@ fetchDecisions demoteCSJDynamoAndIgnoreInflightBlocks ) candidatesAndPeers = do - peersOrder@PeersOrder {peersOrderCurrent, peersOrderOthers} <- + peersOrder <- -- Align the peers order with the actual peers; this consists in removing -- all peers from the peers order that are not in the actual peers list and -- adding at the end of the peers order all the actual peers that were not @@ -120,18 +120,7 @@ fetchDecisions -- the peers order, then we have shifted our focus: we make the new peer our -- current one and we put back the previous current peer at the beginning of -- the queue; not the end, because it has not done anything wrong. - case theDecision of - Just (_, (_, _, _, thePeer, _)) - | Just thePeer /= peersOrderCurrent -> do - peersOrderStart' <- getMonotonicTime - let peersOrder' = - PeersOrder - { peersOrderCurrent = Just thePeer, - peersOrderStart = peersOrderStart', - peersOrderOthers = mcons peersOrderCurrent (filter (/= thePeer) peersOrderOthers) - } - writePeersOrder peersOrder' - _ -> pure () + checkChangeOfCurrentPeer theDecision peersOrder pure $ maybe [] (singleton . first Right) theDecision @@ -170,3 +159,17 @@ fetchDecisions } traverse_ demoteCSJDynamoAndIgnoreInflightBlocks peersOrderCurrent pure peersOrder' + + checkChangeOfCurrentPeer :: Maybe (any, PeerInfo header peer extra) -> PeersOrder peer -> m () + checkChangeOfCurrentPeer theDecision PeersOrder {peersOrderCurrent, peersOrderOthers} = + case theDecision of + Just (_, (_, _, _, thePeer, _)) + | Just thePeer /= peersOrderCurrent -> do + peersOrderStart <- getMonotonicTime + writePeersOrder $ + PeersOrder + { peersOrderCurrent = Just thePeer, + peersOrderStart, + peersOrderOthers = mcons peersOrderCurrent (filter (/= thePeer) peersOrderOthers) + } + _ -> pure () From 3b978c1c5e5b95dcc83079e922b777016d856f44 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 10 Jul 2024 14:01:19 +0200 Subject: [PATCH 063/136] Cleanup --- .../Ouroboros/Network/BlockFetch/Decision.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index f10934cf10e..a5bc7b0dc18 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -92,13 +92,13 @@ fetchDecisions ) candidatesAndPeers = do peersOrder <- - -- Align the peers order with the actual peers; this consists in removing - -- all peers from the peers order that are not in the actual peers list and - -- adding at the end of the peers order all the actual peers that were not - -- there before. - alignPeersOrderWithActualPeers - peersOrder0 - (map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers) + peersOrder0 + -- Align the peers order with the actual peers; this consists in removing + -- all peers from the peers order that are not in the actual peers list and + -- adding at the end of the peers order all the actual peers that were not + -- there before. + & alignPeersOrderWithActualPeers + (map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers) -- If the chain selection has been starved recently, that is after the -- current peer started (and a grace period), then the current peer is -- bad. We push it at the end of the queue, demote it from CSJ dynamo, @@ -126,10 +126,10 @@ fetchDecisions maybe [] (singleton . first Right) theDecision ++ map (first Left) declines where - alignPeersOrderWithActualPeers :: PeersOrder peer -> [peer] -> PeersOrder peer + alignPeersOrderWithActualPeers :: [peer] -> PeersOrder peer -> PeersOrder peer alignPeersOrderWithActualPeers - PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} - actualPeers = + actualPeers + PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = let peersOrderCurrent' = case peersOrderCurrent of Just peersOrderCurrent_ | peersOrderCurrent_ `elem` actualPeers -> peersOrderCurrent _ -> Nothing From 89ffb2e21ef3858c6536f84c83a70dfa17c88a6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 11 Jul 2024 07:31:56 +0200 Subject: [PATCH 064/136] Remove useless comment --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 6d04802854b..fc8a32b30a9 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -33,9 +33,6 @@ import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkS import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Ouroboros.Network.BlockFetch.Decision.Common --- REVIEW: We should not import anything from 'Decision.Deadline'; if the need --- arises, we should move the interesting piece of code to 'Decision.Common'. --- This is to be done on demand. -- | A trivial foldable data structure with a 'Semigroup' instance that -- concatenates in @O(1)@. Only meant for short-term use, followed by one fold. From d4a453db395bda67b848b8799a8a5fff328cc09a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 11 Jul 2024 07:50:47 +0200 Subject: [PATCH 065/136] Improve comments of `filterNotAlready...` --- .../Network/BlockFetch/Decision/Common.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index bbe8edf7772..18d2bf78800 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -395,12 +395,13 @@ of individual blocks without their relationship to each other. -} --- | Find the fragments of the chain suffix that we still need to fetch, these --- are the fragments covering blocks that have not yet been fetched and are --- not currently in the process of being fetched from this peer. +-- | Find the fragments of the chain suffix that we still need to fetch because +-- they are covering blocks that have not yet been fetched. -- -- Typically this is a single fragment forming a suffix of the chain, but in -- the general case we can get a bunch of discontiguous chain fragments. +-- +-- See also 'filterNotAlreadyInFlightWithPeer'. filterNotAlreadyFetched :: (HasHeader header, HeaderHash header ~ HeaderHash block) => (Point block -> Bool) -> @@ -427,6 +428,14 @@ filterNotAlreadyFetched' alreadyDownloaded fetchedMaxSlotNo = ((filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo =<< mcandidate), peer) ) +-- | Find the fragments of the chain suffix that we still need to fetch because +-- they are covering blocks that are not currently in the process of being +-- fetched from this peer. +-- +-- Typically this is a single fragment forming a suffix of the chain, but in +-- the general case we can get a bunch of discontiguous chain fragments. +-- +-- See also 'filterNotAlreadyFetched' filterNotAlreadyInFlightWithPeer :: (HasHeader header) => PeerFetchInFlight header -> From 0be0889f6f0bc7687556f19edff9e05f4821d62f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 11 Jul 2024 08:26:36 +0200 Subject: [PATCH 066/136] Mention that grossRequest implies refinedRequest --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index fc8a32b30a9..b0312590ccd 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -231,8 +231,9 @@ selectThePeer . snd <$> theFragments - -- For each peer, check whether its candidate contains the gross request - -- in its entirety, otherwise decline it. + -- For each peer, check whether its candidate contains the gross request in + -- its entirety, otherwise decline it. This will guarantee that the + -- remaining peers can serve the refine request that we will craft later. peers <- filterM ( \(candidate, peer) -> From d28e315fc5fb1d24289f0727d4766da0bf3c0c67 Mon Sep 17 00:00:00 2001 From: Nicolas Jeannerod Date: Thu, 11 Jul 2024 08:38:50 +0200 Subject: [PATCH 067/136] Apply suggestions by @facundominguez MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Facundo Domínguez --- .../Network/BlockFetch/Decision/BulkSync.hs | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index b0312590ccd..2434eaebff3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -19,11 +19,11 @@ import Data.List (sortOn) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Data.Ord (Down(Down)) -import Cardano.Prelude (guard) +import Cardano.Prelude (guard, partitionEithers) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -172,19 +172,15 @@ selectTheCandidate . sortOn (Down . headBlockNo . fst) where -- Very ad-hoc helper. + -- Write all of the declined peers, and find the candidate fragment + -- if there is any. separateDeclinedAndStillInRace :: [(FetchDecision (ChainSuffix header), peerInfo)] -> WithDeclined peerInfo (Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)])) separateDeclinedAndStillInRace decisions = do - inRace <- - catMaybes - <$> traverse - ( \(decision, peer) -> - case decision of - Left reason -> tell (List [(reason, peer)]) >> pure Nothing - Right candidate -> pure $ Just (candidate, peer) - ) - decisions + let (declined, inRace) = partitionEithers + [ bimap ((,p)) ((,p)) d | (d, p) <- decisions ] + tell (List declined) return $ ((,inRace) . fst . NE.head) <$> nonEmpty inRace -- | Given _the_ candidate fragment to sync from, and a list of peers (with From 38901751623a2fce1f257f2e7d41aa3017f391b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Thu, 11 Jul 2024 10:34:29 +0200 Subject: [PATCH 068/136] Check if blocks in flight before demoting --- .../Ouroboros/Network/BlockFetch/Decision.hs | 40 ++++++++++++------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index a5bc7b0dc18..f01cfa1b613 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -24,14 +24,14 @@ module Ouroboros.Network.BlockFetch.Decision import Data.Bifunctor (Bifunctor(..)) import Data.Hashable -import Data.List (singleton) -import Data.Foldable (traverse_) +import Data.List (singleton, find) import Data.Function ((&)) +import qualified Data.Map.Strict as Map import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..), addTime) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), msnoc, mcons) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), mcons, PeerFetchInFlight (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..), ChainSelStarvation) import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), @@ -148,17 +148,20 @@ fetchDecisions lastStarvationTime <- case chainSelStarvation of ChainSelStarvationEndedAt time -> pure time ChainSelStarvationOngoing -> getMonotonicTime - if lastStarvationTime < addTime bulkSyncGracePeriod peersOrderStart - then pure peersOrder - else do - let peersOrder' = - PeersOrder - { peersOrderCurrent = Nothing, - peersOrderOthers = msnoc peersOrderOthers peersOrderCurrent, - peersOrderStart - } - traverse_ demoteCSJDynamoAndIgnoreInflightBlocks peersOrderCurrent - pure peersOrder' + case peersOrderCurrent of + Just peersOrderCurrent_ + | peerHasBlocksInFlight peersOrderCurrent_ + && lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart -> + do + let peersOrder' = + PeersOrder + { peersOrderCurrent = Nothing, + peersOrderOthers = snoc peersOrderOthers peersOrderCurrent_, + peersOrderStart + } + demoteCSJDynamoAndIgnoreInflightBlocks peersOrderCurrent_ + pure peersOrder' + _ -> pure peersOrder checkChangeOfCurrentPeer :: Maybe (any, PeerInfo header peer extra) -> PeersOrder peer -> m () checkChangeOfCurrentPeer theDecision PeersOrder {peersOrderCurrent, peersOrderOthers} = @@ -173,3 +176,12 @@ fetchDecisions peersOrderOthers = mcons peersOrderCurrent (filter (/= thePeer) peersOrderOthers) } _ -> pure () + + peerHasBlocksInFlight peer = + case find (\(_, (_, _, _, peer', _)) -> peer == peer') candidatesAndPeers of + Just (_, (_, inflight, _, _, _)) -> not $ Map.null $ peerFetchBlocksInFlight inflight + Nothing -> error "blocksInFlightForPeer" + +snoc :: [a] -> a -> [a] +snoc [] a = [a] +snoc (x : xs) a = x : snoc xs a From 9e69d6048711722e8a4a3993b7be684c2afa03f1 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 11 Jul 2024 12:59:56 +0200 Subject: [PATCH 069/136] Compatiblity with older GHC/packages in `cardano-node` --- .../src/Ouroboros/Network/BlockFetch/Decision.hs | 5 +++-- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 3 ++- .../src/Ouroboros/Network/BlockFetch/Decision/Common.hs | 1 + 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index f01cfa1b613..3d366cbe1bb 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -24,7 +24,8 @@ module Ouroboros.Network.BlockFetch.Decision import Data.Bifunctor (Bifunctor(..)) import Data.Hashable -import Data.List (singleton, find) +import Data.List (find) +import Data.Maybe (maybeToList) import Data.Function ((&)) import qualified Data.Map.Strict as Map import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..), addTime) @@ -123,7 +124,7 @@ fetchDecisions checkChangeOfCurrentPeer theDecision peersOrder pure $ - maybe [] (singleton . first Right) theDecision + map (first Right) (maybeToList theDecision) ++ map (first Left) declines where alignPeersOrderWithActualPeers :: [peer] -> PeersOrder peer -> PeersOrder peer diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 2434eaebff3..a5eacaa4d62 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} @@ -12,7 +13,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( import Control.Monad (filterM) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) -import Control.Monad.Writer.CPS (Writer, runWriter, MonadWriter (tell)) +import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) import Data.Foldable (foldl') import Data.List (sortOn) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs index 18d2bf78800..3f4c777ec05 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} From 8c07b585adedc1b651cac285f0c5369ba1cd1c00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 00:42:07 +0200 Subject: [PATCH 070/136] Fix `PeersOrder` --- .../Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index a5eacaa4d62..c1146a4c068 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -240,12 +240,13 @@ selectThePeer ) candidates - -- Order the peers according to the peer order that we have been given, - -- then separate between declined peers and the others. + -- Order the peers according to the peer order that we have been given, then + -- separate between declined peers and the others. NOTE: The order in which + -- we bind the lists in the comprehension is capital. let peersOrdered = [ (candidate, peerInfo) - | (candidate, peerInfo@(_, _, _, peer, _)) <- peers, - peer' <- mcons (peersOrderCurrent peersOrder) (peersOrderOthers peersOrder), + | peer' <- mcons (peersOrderCurrent peersOrder) (peersOrderOthers peersOrder), + (candidate, peerInfo@(_, _, _, peer, _)) <- peers, peer == peer' ] From 59c11f9643d8a75689ae3670af09b51b3ccde4a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 01:05:28 +0200 Subject: [PATCH 071/136] Move important part of `fetchDecisions` into BulkSync --- .../Ouroboros/Network/BlockFetch/Decision.hs | 124 ++-------------- .../Network/BlockFetch/Decision/BulkSync.hs | 132 +++++++++++++++++- 2 files changed, 143 insertions(+), 113 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 3d366cbe1bb..916300859de 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -22,17 +22,12 @@ module Ouroboros.Network.BlockFetch.Decision , fetchRequestDecisions ) where -import Data.Bifunctor (Bifunctor(..)) import Data.Hashable -import Data.List (find) -import Data.Maybe (maybeToList) -import Data.Function ((&)) -import qualified Data.Map.Strict as Map -import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..), addTime) +import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), mcons, PeerFetchInFlight (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..), ChainSelStarvation) import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), @@ -40,8 +35,7 @@ import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), P selectForkSuffixes) import Ouroboros.Network.BlockFetch.Decision.Deadline (fetchDecisionsDeadline, prioritisePeerChains, fetchRequestDecisions) -import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSync) -import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) +import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSyncM) fetchDecisions :: forall peer header block m extra. @@ -81,108 +75,20 @@ fetchDecisions candidatesAndPeers fetchDecisions - fetchDecisionPolicy@FetchDecisionPolicy {bulkSyncGracePeriod} + fetchDecisionPolicy FetchModeBulkSync currentChain fetchedBlocks fetchedMaxSlotNo chainSelStarvation - ( peersOrder0, - writePeersOrder, - demoteCSJDynamoAndIgnoreInflightBlocks - ) - candidatesAndPeers = do - peersOrder <- - peersOrder0 - -- Align the peers order with the actual peers; this consists in removing - -- all peers from the peers order that are not in the actual peers list and - -- adding at the end of the peers order all the actual peers that were not - -- there before. - & alignPeersOrderWithActualPeers - (map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers) - -- If the chain selection has been starved recently, that is after the - -- current peer started (and a grace period), then the current peer is - -- bad. We push it at the end of the queue, demote it from CSJ dynamo, - -- and ignore its in-flight blocks for the future. - & checkLastChainSelStarvation - - -- Compute the actual block fetch decision. This contains only declines and - -- at most one request. 'theDecision' is therefore a 'Maybe'. - let (theDecision, declines) = - fetchDecisionsBulkSync - fetchDecisionPolicy - currentChain - fetchedBlocks - fetchedMaxSlotNo - peersOrder - candidatesAndPeers - - -- If the peer that is supposed to fetch the block is not the current one in - -- the peers order, then we have shifted our focus: we make the new peer our - -- current one and we put back the previous current peer at the beginning of - -- the queue; not the end, because it has not done anything wrong. - checkChangeOfCurrentPeer theDecision peersOrder - - pure $ - map (first Right) (maybeToList theDecision) - ++ map (first Left) declines - where - alignPeersOrderWithActualPeers :: [peer] -> PeersOrder peer -> PeersOrder peer - alignPeersOrderWithActualPeers - actualPeers - PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = - let peersOrderCurrent' = case peersOrderCurrent of - Just peersOrderCurrent_ | peersOrderCurrent_ `elem` actualPeers -> peersOrderCurrent - _ -> Nothing - peersOrderOthers' = - filter (`elem` actualPeers) peersOrderOthers - ++ filter (\peer -> peer `notElem` peersOrderOthers && Just peer /= peersOrderCurrent) actualPeers - in PeersOrder - { peersOrderCurrent = peersOrderCurrent', - peersOrderOthers = peersOrderOthers', - peersOrderStart - } - - checkLastChainSelStarvation :: PeersOrder peer -> m (PeersOrder peer) - checkLastChainSelStarvation - peersOrder@PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = do - lastStarvationTime <- case chainSelStarvation of - ChainSelStarvationEndedAt time -> pure time - ChainSelStarvationOngoing -> getMonotonicTime - case peersOrderCurrent of - Just peersOrderCurrent_ - | peerHasBlocksInFlight peersOrderCurrent_ - && lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart -> - do - let peersOrder' = - PeersOrder - { peersOrderCurrent = Nothing, - peersOrderOthers = snoc peersOrderOthers peersOrderCurrent_, - peersOrderStart - } - demoteCSJDynamoAndIgnoreInflightBlocks peersOrderCurrent_ - pure peersOrder' - _ -> pure peersOrder - - checkChangeOfCurrentPeer :: Maybe (any, PeerInfo header peer extra) -> PeersOrder peer -> m () - checkChangeOfCurrentPeer theDecision PeersOrder {peersOrderCurrent, peersOrderOthers} = - case theDecision of - Just (_, (_, _, _, thePeer, _)) - | Just thePeer /= peersOrderCurrent -> do - peersOrderStart <- getMonotonicTime - writePeersOrder $ - PeersOrder - { peersOrderCurrent = Just thePeer, - peersOrderStart, - peersOrderOthers = mcons peersOrderCurrent (filter (/= thePeer) peersOrderOthers) - } - _ -> pure () - - peerHasBlocksInFlight peer = - case find (\(_, (_, _, _, peer', _)) -> peer == peer') candidatesAndPeers of - Just (_, (_, inflight, _, _, _)) -> not $ Map.null $ peerFetchBlocksInFlight inflight - Nothing -> error "blocksInFlightForPeer" - -snoc :: [a] -> a -> [a] -snoc [] a = [a] -snoc (x : xs) a = x : snoc xs a + peersOrderHandlers + candidatesAndPeers + = + fetchDecisionsBulkSyncM + fetchDecisionPolicy + currentChain + fetchedBlocks + fetchedMaxSlotNo + chainSelStarvation + peersOrderHandlers + candidatesAndPeers diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index c1146a4c068..92ed16d15cf 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -8,23 +8,24 @@ -- | This module contains the part of the block fetch decisions process that is -- specific to the bulk sync mode. module Ouroboros.Network.BlockFetch.Decision.BulkSync ( - fetchDecisionsBulkSync + fetchDecisionsBulkSyncM ) where import Control.Monad (filterM) +import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime), addTime) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) import Data.Foldable (foldl') -import Data.List (sortOn) +import Data.List (sortOn, find) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, maybeToList) import qualified Data.Set as Set import Data.Ord (Down(Down)) -import Cardano.Prelude (guard, partitionEithers) +import Cardano.Prelude (guard, partitionEithers, (&)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -32,6 +33,7 @@ import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), mcons, PeerFetchBlockInFlight (..), PeerFetchStatus (..), PeerFetchInFlight (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) import Ouroboros.Network.BlockFetch.Decision.Common @@ -56,6 +58,128 @@ type WithDeclined peer = Writer (ListConcat (FetchDecline, peer)) runWithDeclined :: WithDeclined peer a -> (a, ListConcat (FetchDecline, peer)) runWithDeclined = runWriter +fetchDecisionsBulkSyncM + :: forall peer header block m extra. + (Ord peer, + HasHeader header, + HeaderHash header ~ HeaderHash block, MonadMonotonicTime m) + => FetchDecisionPolicy header + -> AnchoredFragment header + -> (Point block -> Bool) + -> MaxSlotNo + -> ChainSelStarvation + -> ( PeersOrder peer + , PeersOrder peer -> m () + , peer -> m () + ) + -> [(AnchoredFragment header, PeerInfo header peer extra)] + -> m [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] +fetchDecisionsBulkSyncM + fetchDecisionPolicy@FetchDecisionPolicy {bulkSyncGracePeriod} + currentChain + fetchedBlocks + fetchedMaxSlotNo + chainSelStarvation + ( peersOrder0, + writePeersOrder, + demoteCSJDynamoAndIgnoreInflightBlocks + ) + candidatesAndPeers = do + peersOrder <- + peersOrder0 + -- Align the peers order with the actual peers; this consists in removing + -- all peers from the peers order that are not in the actual peers list and + -- adding at the end of the peers order all the actual peers that were not + -- there before. + & alignPeersOrderWithActualPeers + (map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers) + -- If the chain selection has been starved recently, that is after the + -- current peer started (and a grace period), then the current peer is + -- bad. We push it at the end of the queue, demote it from CSJ dynamo, + -- and ignore its in-flight blocks for the future. + & checkLastChainSelStarvation + + -- Compute the actual block fetch decision. This contains only declines and + -- at most one request. 'theDecision' is therefore a 'Maybe'. + let (theDecision, declines) = + fetchDecisionsBulkSync + fetchDecisionPolicy + currentChain + fetchedBlocks + fetchedMaxSlotNo + peersOrder + candidatesAndPeers + + -- If the peer that is supposed to fetch the block is not the current one in + -- the peers order, then we have shifted our focus: we make the new peer our + -- current one and we put back the previous current peer at the beginning of + -- the queue; not the end, because it has not done anything wrong. + checkChangeOfCurrentPeer theDecision peersOrder + + pure $ + map (first Right) (maybeToList theDecision) + ++ map (first Left) declines + where + alignPeersOrderWithActualPeers :: [peer] -> PeersOrder peer -> PeersOrder peer + alignPeersOrderWithActualPeers + actualPeers + PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = + let peersOrderCurrent' = case peersOrderCurrent of + Just peersOrderCurrent_ | peersOrderCurrent_ `elem` actualPeers -> peersOrderCurrent + _ -> Nothing + peersOrderOthers' = + filter (`elem` actualPeers) peersOrderOthers + ++ filter (\peer -> peer `notElem` peersOrderOthers && Just peer /= peersOrderCurrent) actualPeers + in PeersOrder + { peersOrderCurrent = peersOrderCurrent', + peersOrderOthers = peersOrderOthers', + peersOrderStart + } + + checkLastChainSelStarvation :: PeersOrder peer -> m (PeersOrder peer) + checkLastChainSelStarvation + peersOrder@PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = do + lastStarvationTime <- case chainSelStarvation of + ChainSelStarvationEndedAt time -> pure time + ChainSelStarvationOngoing -> getMonotonicTime + case peersOrderCurrent of + Just peersOrderCurrent_ + | peerHasBlocksInFlight peersOrderCurrent_ + && lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart -> + do + let peersOrder' = + PeersOrder + { peersOrderCurrent = Nothing, + peersOrderOthers = snoc peersOrderOthers peersOrderCurrent_, + peersOrderStart + } + demoteCSJDynamoAndIgnoreInflightBlocks peersOrderCurrent_ + pure peersOrder' + _ -> pure peersOrder + + checkChangeOfCurrentPeer :: Maybe (any, PeerInfo header peer extra) -> PeersOrder peer -> m () + checkChangeOfCurrentPeer theDecision PeersOrder {peersOrderCurrent, peersOrderOthers} = + case theDecision of + Just (_, (_, _, _, thePeer, _)) + | Just thePeer /= peersOrderCurrent -> do + peersOrderStart <- getMonotonicTime + writePeersOrder $ + PeersOrder + { peersOrderCurrent = Just thePeer, + peersOrderStart, + peersOrderOthers = mcons peersOrderCurrent (filter (/= thePeer) peersOrderOthers) + } + _ -> pure () + + peerHasBlocksInFlight peer = + case find (\(_, (_, _, _, peer', _)) -> peer == peer') candidatesAndPeers of + Just (_, (_, inflight, _, _, _)) -> not $ Map.null $ peerFetchBlocksInFlight inflight + Nothing -> error "blocksInFlightForPeer" + +snoc :: [a] -> a -> [a] +snoc [] a = [a] +snoc (x : xs) a = x : snoc xs a + -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. fetchDecisionsBulkSync :: From 4361031c47e95d78d3d7ea43492f9db3cc4aab9e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 01:34:59 +0200 Subject: [PATCH 072/136] Bring back everything to `Deadline` ...so that the previous comments make sense --- ouroboros-network/ouroboros-network.cabal | 1 - .../Ouroboros/Network/BlockFetch/Decision.hs | 6 +- .../Network/BlockFetch/Decision/BulkSync.hs | 2 +- .../Network/BlockFetch/Decision/Common.hs | 687 ----------------- .../Network/BlockFetch/Decision/Deadline.hs | 704 ++++++++++++++++-- 5 files changed, 660 insertions(+), 740 deletions(-) delete mode 100644 ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index d52d378b9ec..590da01ade3 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -34,7 +34,6 @@ library Ouroboros.Network.BlockFetch.ClientState Ouroboros.Network.BlockFetch.Decision Ouroboros.Network.BlockFetch.Decision.BulkSync - Ouroboros.Network.BlockFetch.Decision.Common Ouroboros.Network.BlockFetch.Decision.Deadline Ouroboros.Network.BlockFetch.DeltaQ Ouroboros.Network.BlockFetch.State diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index 916300859de..bffae41b904 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -30,11 +30,9 @@ import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..), ChainSelStarvation) -import Ouroboros.Network.BlockFetch.Decision.Common (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), +import Ouroboros.Network.BlockFetch.Decision.Deadline (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), filterPlausibleCandidates, filterNotAlreadyFetched, filterNotAlreadyInFlightWithPeer, - selectForkSuffixes) -import Ouroboros.Network.BlockFetch.Decision.Deadline (fetchDecisionsDeadline, - prioritisePeerChains, fetchRequestDecisions) + selectForkSuffixes, fetchDecisionsDeadline, prioritisePeerChains, fetchRequestDecisions) import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSyncM) fetchDecisions diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 92ed16d15cf..74b6707e314 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -35,7 +35,7 @@ import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkS import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) -import Ouroboros.Network.BlockFetch.Decision.Common +import Ouroboros.Network.BlockFetch.Decision.Deadline -- | A trivial foldable data structure with a 'Semigroup' instance that -- concatenates in @O(1)@. Only meant for short-term use, followed by one fold. diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs deleted file mode 100644 index 3f4c777ec05..00000000000 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Common.hs +++ /dev/null @@ -1,687 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | This module contains the part of the block fetch decisions process that is --- common to both the bulk sync and deadline modes. -module Ouroboros.Network.BlockFetch.Decision.Common ( - FetchDecisionPolicy (..) - , PeerInfo - , FetchDecision - , FetchDecline (..) - , ChainSuffix (..) - , filterNotAlreadyFetched - , filterNotAlreadyInFlightWithPeer - , (?!) - , CandidateFragments - , filterWithMaxSlotNo - , filterPlausibleCandidates - , selectForkSuffixes - , filterNotAlreadyInFlightWithPeer' - , filterNotAlreadyFetched' - , fetchRequestDecision - , selectBlocksUpToLimits -) where - -import GHC.Stack (HasCallStack) -import Control.Exception (assert) -import Control.Monad (guard) -import Control.Monad.Class.MonadTime.SI (DiffTime) -import qualified Data.Map.Strict as Map - -import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq (..)) -import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Block (HasHeader, HeaderHash, Point, MaxSlotNo (..), castPoint, blockPoint, blockSlot) -import Ouroboros.Network.BlockFetch.ClientState (PeerFetchInFlight (..), PeerFetchStatus (..), FetchRequest (..)) -import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) -import Ouroboros.Network.DeltaQ ( PeerGSV ) -import Ouroboros.Network.SizeInBytes ( SizeInBytes ) -import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..)) - -data FetchDecisionPolicy header = FetchDecisionPolicy { - maxInFlightReqsPerPeer :: Word, -- A protocol constant. - - maxConcurrencyBulkSync :: Word, - maxConcurrencyDeadline :: Word, - decisionLoopInterval :: DiffTime, - peerSalt :: Int, - bulkSyncGracePeriod :: DiffTime, - - plausibleCandidateChain :: HasCallStack - => AnchoredFragment header - -> AnchoredFragment header -> Bool, - - compareCandidateChains :: HasCallStack - => AnchoredFragment header - -> AnchoredFragment header - -> Ordering, - - blockFetchSize :: header -> SizeInBytes - } - -type PeerInfo header peer extra = - ( PeerFetchStatus header, - PeerFetchInFlight header, - PeerGSV, - peer, - extra - ) - --- | Throughout the decision making process we accumulate reasons to decline --- to fetch any blocks. This type is used to wrap intermediate and final --- results. --- -type FetchDecision result = Either FetchDecline result - --- | All the various reasons we can decide not to fetch blocks from a peer. --- --- It is worth highlighting which of these reasons result from competition --- among upstream peers. --- --- * 'FetchDeclineInFlightOtherPeer': decline this peer because all the --- unfetched blocks of its candidate chain have already been requested from --- other peers. This reason reflects the least-consequential competition --- among peers: the competition that determines merely which upstream peer to --- burden with the request (eg the one with the best --- 'Ouroboros.Network.BlockFetch.DeltaQ.DeltaQ' metrics). The consequences --- are relatively minor because the unfetched blocks on this peer's candidate --- chain will be requested regardless; it's merely a question of "From who?". --- (One exception: if an adversarial peer wins this competition such that the --- blocks are only requested from them, then it may be possible that this --- decision determines whether the blocks are ever /received/. But that --- depends on details of timeouts, a longer competing chain being soon --- received within those timeouts, and so on.) --- --- * 'FetchDeclineChainNotPlausible': decline this peer because the node has --- already fetched, validated, and selected a chain better than its candidate --- chain from other peers (or from the node's own block forge). Because the --- node's current selection is influenced by what blocks other peers have --- recently served (or it recently minted), this reason reflects that peers --- /indirectly/ compete by serving as long of a chain as possible and as --- promptly as possible. When the tips of the peers' selections are all --- within their respective forecast horizons (see --- 'Ouroboros.Consensus.Ledger.SupportsProtocol.ledgerViewForecastAt'), then --- the length of their candidate chains will typically be the length of their --- selections, since the ChainSync is free to race ahead (in contrast, the --- BlockFetch pipeline depth is bounded such that it will, for a syncing --- node, not be able to request all blocks between the selection and the end --- of the forecast window). But if one or more of their tips is beyond the --- horizon, then the relative length of the candidate chains is more --- complicated, influenced by both the relative density of the chains' --- suffixes and the relative age of the chains' intersection with the node's --- selection (since each peer's forecast horizon is a fixed number of slots --- after the candidate's successor of that intersection). --- --- * 'FetchDeclineConcurrencyLimit': decline this peer while the node has --- already fully allocated the artificially scarce 'maxConcurrentFetchPeers' --- resource amongst its other peers. This reason reflects the --- least-fundamental competition: it's the only way a node would decline a --- candidate chain C that it would immediately switch to if C had somehow --- already been fetched (and any better current candidates hadn't). It is --- possible that this peer's candidate fragment is better than the candidate --- fragments of other peers, but that should only happen ephemerally (eg for --- a brief while immediately after first connecting to this peer). --- --- * 'FetchDeclineChainIntersectionTooDeep': decline this peer because the node's --- selection has more than @K@ blocks that are not on this peer's candidate --- chain. Typically, this reason occurs after the node has been declined---ie --- lost the above competitions---for a long enough duration. This decision --- only arises if the BlockFetch decision logic wins a harmless race against --- the ChainSync client once the node's selection gets longer, since --- 'Ouroboros.Consensus.MiniProtocol.ChainSync.Client.ForkTooDeep' --- disconnects from such a peer. --- -data FetchDecline = - -- | This peer's candidate chain is not longer than our chain. For more - -- details see - -- 'Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface.mkBlockFetchConsensusInterface' - -- which implements 'plausibleCandidateChain'. - -- - FetchDeclineChainNotPlausible - - -- | Switching to this peer's candidate chain would require rolling back - -- more than @K@ blocks. - -- - | FetchDeclineChainIntersectionTooDeep - - -- | Every block on this peer's candidate chain has already been fetched. - -- - | FetchDeclineAlreadyFetched - - -- | This peer's candidate chain has already been requested from this - -- peer. - -- - | FetchDeclineInFlightThisPeer - - -- | Some blocks on this peer's candidate chain have not yet been fetched, - -- but all of those have already been requested from other peers. - -- - | FetchDeclineInFlightOtherPeer - - -- | This peer's BlockFetch client is shutting down, see - -- 'PeerFetchStatusShutdown'. - -- - | FetchDeclinePeerShutdown - - -- | Blockfetch is starting up and waiting on corresponding Chainsync. - | FetchDeclinePeerStarting - - - -- The reasons above this comment are fundamental and/or obvious. On the - -- other hand, the reasons below are heuristic. - - - -- | This peer is in a potentially-temporary state in which it has not - -- responded to us within a certain expected time limit, see - -- 'PeerFetchStatusAberrant'. - -- - | FetchDeclinePeerSlow - - -- | This peer is not under the 'maxInFlightReqsPerPeer' limit. - -- - -- The argument is the 'maxInFlightReqsPerPeer' constant. - -- - | FetchDeclineReqsInFlightLimit !Word - - -- | This peer is not under the 'inFlightBytesHighWatermark' bytes limit. - -- - -- The arguments are: - -- - -- * number of bytes currently in flight for that peer - -- * the configured 'inFlightBytesLowWatermark' constant - -- * the configured 'inFlightBytesHighWatermark' constant - -- - | FetchDeclineBytesInFlightLimit !SizeInBytes !SizeInBytes !SizeInBytes - - -- | This peer is not under the 'inFlightBytesLowWatermark'. - -- - -- The arguments are: - -- - -- * number of bytes currently in flight for that peer - -- * the configured 'inFlightBytesLowWatermark' constant - -- * the configured 'inFlightBytesHighWatermark' constant - -- - | FetchDeclinePeerBusy !SizeInBytes !SizeInBytes !SizeInBytes - - -- | The node is not under the 'maxConcurrentFetchPeers' limit. - -- - -- The arguments are: - -- - -- * the current 'FetchMode' - -- * the corresponding configured limit constant, either - -- 'maxConcurrencyBulkSync' or 'maxConcurrencyDeadline' - -- - | FetchDeclineConcurrencyLimit !FetchMode !Word - deriving (Eq, Show) - --- | The combination of a 'ChainSuffix' and a list of discontiguous --- 'AnchoredFragment's: --- --- * When comparing two 'CandidateFragments' as candidate chains, we use the --- 'ChainSuffix'. --- --- * To track which blocks of that candidate still have to be downloaded, we --- use a list of discontiguous 'AnchoredFragment's. --- -type CandidateFragments header = (ChainSuffix header, [AnchoredFragment header]) - -{- -Of course we would at most need to download the blocks in a candidate chain -that are not already in the current chain. So we must find those intersections. - -Before we do that, lets define how we represent a suffix of a chain. We do this -very simply as a chain fragment: exactly those blocks contained in the suffix. -A chain fragment is of course not a chain, but has many similar invariants. - -We will later also need to represent chain ranges when we send block fetch -requests. We do this using a pair of points: the first and last blocks in the -range. While we can represent an empty chain fragment, we cannot represent an -empty fetch range, but this is ok since we never request empty ranges. - - Chain fragment - ┌───┐ - │ ◉ │ Start of range, inclusive - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ ◉ │ End of range, inclusive. - └───┘ --} - --- | A chain suffix, obtained by intersecting a candidate chain with the --- current chain. --- --- The anchor point of a 'ChainSuffix' will be a point within the bounds of --- the current chain ('AF.withinFragmentBounds'), indicating that it forks off --- in the last @K@ blocks. --- --- A 'ChainSuffix' must be non-empty, as an empty suffix, i.e. the candidate --- chain is equal to the current chain, would not be a plausible candidate. -newtype ChainSuffix header = - ChainSuffix { getChainSuffix :: AnchoredFragment header } - -{- -We have the node's /current/ or /adopted/ chain. This is the node's chain in -the sense specified by the Ouroboros algorithm. It is a fully verified chain -with block bodies and a ledger state. - - ┆ ┆ - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ │ - ├───┤ - │ │ - ───┴───┴─── current chain length (block number) - -With chain selection we are interested in /candidate/ chains. We have these -candidate chains in the form of chains of verified headers, but without bodies. - -The consensus layer gives us the current set of candidate chains from our peers -and we have the task of selecting which block bodies to download, and then -passing those block bodes back to the consensus layer. The consensus layer will -try to validate them and decide if it wants to update its current chain. - - ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ └───┘ - │ │ │ │ │ │ │ │ - ───┴───┴─────┼───┼─────┼───┼─────┼───┼───────────── current chain length - │ │ │ │ │ │ - current ├───┤ ├───┤ └───┘ - (blocks) │ │ │ │ - └───┘ └───┘ - A B C D - candidates - (headers) - -In this example we have four candidate chains, with all but chain D strictly -longer than our current chain. - -In general there are many candidate chains. We make a distinction between a -candidate chain and the peer from which it is available. It is often the -case that the same chain is available from multiple peers. We will try to be -clear about when we are referring to chains or the combination of a chain and -the peer from which it is available. - -For the sake of the example let us assume we have the four chains above -available from the following peers. - -peer 1 2 3 4 5 6 7 - ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ - ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ │ │ │ │ - ├───┤ ├───┤ ├───┤ ├───┤ └───┘ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ │ │ - ──┼───┼─────┼───┼─────┼───┼─────┼───┼───────────────┼───┼─────┼───┼── - │ │ │ │ │ │ │ │ │ │ │ │ - └───┘ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ - │ │ │ │ │ │ │ │ │ │ - └───┘ └───┘ └───┘ └───┘ └───┘ -chain C A B A D B A - -This is the form in which we are informed about candidate chains from the -consensus layer, the combination of a chain and the peer it is from. This -makes sense, since these things change independently. - -We will process the chains in this form, keeping the peer/chain combination all -the way through. Although there could in principle be some opportunistic saving -by sharing when multiple peers provide the same chain, taking advantage of this -adds complexity and does nothing to improve our worst case costs. - -We are only interested in candidate chains that are strictly longer than our -current chain. So our first task is to filter down to this set. --} - --- | Keep only those candidate chains that are preferred over the current --- chain. Typically, this means that their length is longer than the length of --- the current chain. --- -filterPlausibleCandidates - :: (AnchoredFragment block -> AnchoredFragment header -> Bool) - -> AnchoredFragment block -- ^ The current chain - -> [(AnchoredFragment header, peerinfo)] - -> [(FetchDecision (AnchoredFragment header), peerinfo)] -filterPlausibleCandidates plausibleCandidateChain currentChain chains = - [ (chain', peer) - | (chain, peer) <- chains - , let chain' = do - guard (plausibleCandidateChain currentChain chain) - ?! FetchDeclineChainNotPlausible - return chain - ] - -{- -We define the /fetch range/ as the suffix of the fork range that has not yet -had its blocks downloaded and block content checked against the headers. - - ┆ ┆ - ├───┤ - │ │ - ├───┤ ┌───┐ - │ │ already │ │ - ├───┤ fetched ├───┤ - │ │ blocks │ │ - ├───┤ ├───┤ - │ │ │░◉░│ ◄ fetch range - ───┴───┴─────┬───┬─────┼───┼─── - │░◉░│ ◄ │░░░│ - └───┘ ├───┤ - │░◉░│ ◄ - └───┘ - -In earlier versions of this scheme we maintained and relied on the invariant -that the ranges of fetched blocks are backwards closed. This meant we never had -discontinuous ranges of fetched or not-yet-fetched blocks. This invariant does -simplify things somewhat by keeping the ranges continuous however it precludes -fetching ranges of blocks from different peers in parallel. - -We do not maintain any such invariant and so we have to deal with there being -gaps in the ranges we have already fetched or are yet to fetch. To keep the -tracking simple we do not track the ranges themselves, rather we track the set -of individual blocks without their relationship to each other. - --} - --- | Find the fragments of the chain suffix that we still need to fetch because --- they are covering blocks that have not yet been fetched. --- --- Typically this is a single fragment forming a suffix of the chain, but in --- the general case we can get a bunch of discontiguous chain fragments. --- --- See also 'filterNotAlreadyInFlightWithPeer'. -filterNotAlreadyFetched :: - (HasHeader header, HeaderHash header ~ HeaderHash block) => - (Point block -> Bool) -> - MaxSlotNo -> - ChainSuffix header -> - FetchDecision (CandidateFragments header) -filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo candidate = - if null fragments - then Left FetchDeclineAlreadyFetched - else Right (candidate, fragments) - where - fragments = filterWithMaxSlotNo notAlreadyFetched fetchedMaxSlotNo (getChainSuffix candidate) - notAlreadyFetched = not . alreadyDownloaded . castPoint . blockPoint - -filterNotAlreadyFetched' :: - (HasHeader header, HeaderHash header ~ HeaderHash block) => - (Point block -> Bool) -> - MaxSlotNo -> - [(FetchDecision (ChainSuffix header), peerinfo)] -> - [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyFetched' alreadyDownloaded fetchedMaxSlotNo = - map - ( \(mcandidate, peer) -> - ((filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo =<< mcandidate), peer) - ) - --- | Find the fragments of the chain suffix that we still need to fetch because --- they are covering blocks that are not currently in the process of being --- fetched from this peer. --- --- Typically this is a single fragment forming a suffix of the chain, but in --- the general case we can get a bunch of discontiguous chain fragments. --- --- See also 'filterNotAlreadyFetched' -filterNotAlreadyInFlightWithPeer :: - (HasHeader header) => - PeerFetchInFlight header -> - CandidateFragments header -> - FetchDecision (CandidateFragments header) -filterNotAlreadyInFlightWithPeer inflight (candidate, chainfragments) = - if null fragments - then Left FetchDeclineInFlightThisPeer - else Right (candidate, fragments) - where - fragments = concatMap (filterWithMaxSlotNo notAlreadyInFlight (peerFetchMaxSlotNo inflight)) chainfragments - notAlreadyInFlight b = blockPoint b `Map.notMember` peerFetchBlocksInFlight inflight - -filterNotAlreadyInFlightWithPeer' :: - (HasHeader header) => - [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, peerinfo)] -> - [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyInFlightWithPeer' = - map - ( \(mcandidatefragments, inflight, peer) -> - ((filterNotAlreadyInFlightWithPeer inflight =<< mcandidatefragments), peer) - ) - --- | The \"oh noes?!\" operator. --- --- In the case of an error, the operator provides a specific error value. --- -(?!) :: Maybe a -> e -> Either e a -Just x ?! _ = Right x -Nothing ?! e = Left e - --- | Filter a fragment. This is an optimised variant that will behave the same --- as 'AnchoredFragment.filter' if the following precondition is satisfied: --- --- PRECONDITION: for all @hdr@ in the chain fragment: if @blockSlot hdr > --- maxSlotNo@ then the predicate should not hold for any header after @hdr@ in --- the chain fragment. --- --- For example, when filtering out already downloaded blocks from the --- fragment, it does not make sense to keep filtering after having encountered --- the highest slot number the ChainDB has seen so far: blocks with a greater --- slot number cannot have been downloaded yet. When the candidate fragments --- get far ahead of the current chain, e.g., @2k@ headers, this optimisation --- avoids the linear cost of filtering these headers when we know in advance --- they will all remain in the final fragment. In case the given slot number --- is 'NoSlotNo', no filtering takes place, as there should be no matches --- because we haven't downloaded any blocks yet. --- --- For example, when filtering out blocks already in-flight for the given --- peer, the given @maxSlotNo@ can correspond to the block with the highest --- slot number that so far has been in-flight for the given peer. When no --- blocks have been in-flight yet, @maxSlotNo@ can be 'NoSlotNo', in which --- case no filtering needs to take place, which makes sense, as there are no --- blocks to filter out. Note that this is conservative: if a block is for --- some reason multiple times in-flight (maybe it has to be redownloaded) and --- the block's slot number matches the @maxSlotNo@, it will now be filtered --- (while the filtering might previously have stopped before encountering the --- block in question). This is fine, as the filter will now include the block, --- because according to the filtering predicate, the block is not in-flight. -filterWithMaxSlotNo - :: forall header. HasHeader header - => (header -> Bool) - -> MaxSlotNo -- ^ @maxSlotNo@ - -> AnchoredFragment header - -> [AnchoredFragment header] -filterWithMaxSlotNo p maxSlotNo = - AF.filterWithStop p ((> maxSlotNo) . MaxSlotNo . blockSlot) - --- | Find the chain suffix for a candidate chain, with respect to the --- current chain. --- -chainForkSuffix - :: (HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) - => AnchoredFragment block -- ^ Current chain. - -> AnchoredFragment header -- ^ Candidate chain - -> Maybe (ChainSuffix header) -chainForkSuffix current candidate = - case AF.intersect current candidate of - Nothing -> Nothing - Just (_, _, _, candidateSuffix) -> - -- If the suffix is empty, it means the candidate chain was equal to - -- the current chain and didn't fork off. Such a candidate chain is - -- not a plausible candidate, so it must have been filtered out. - assert (not (AF.null candidateSuffix)) $ - Just (ChainSuffix candidateSuffix) - -selectForkSuffixes - :: (HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) - => AnchoredFragment block - -> [(FetchDecision (AnchoredFragment header), peerinfo)] - -> [(FetchDecision (ChainSuffix header), peerinfo)] -selectForkSuffixes current chains = - [ (mchain', peer) - | (mchain, peer) <- chains - , let mchain' = do - chain <- mchain - chainForkSuffix current chain ?! FetchDeclineChainIntersectionTooDeep - ] - --- | --- --- This function _does not_ check if the peer is likely to have the blocks in --- the ranges, it only compute a request that respect what the peer's current --- status indicates on their ability to fulfill it. -fetchRequestDecision - :: HasHeader header - => FetchDecisionPolicy header - -> FetchMode - -> Word - -- ^ Number of concurrent fetch peers. Can be set to @0@ to bypass - -- concurrency limits. - -> PeerFetchInFlightLimits - -> PeerFetchInFlight header - -> PeerFetchStatus header - -> FetchDecision [AnchoredFragment header] - -> FetchDecision (FetchRequest header) - -fetchRequestDecision _ _ _ _ _ _ (Left decline) - = Left decline - -fetchRequestDecision _ _ _ _ _ PeerFetchStatusShutdown _ - = Left FetchDeclinePeerShutdown - -fetchRequestDecision _ _ _ _ _ PeerFetchStatusStarting _ - = Left FetchDeclinePeerStarting - -fetchRequestDecision _ _ _ _ _ PeerFetchStatusAberrant _ - = Left FetchDeclinePeerSlow - -fetchRequestDecision FetchDecisionPolicy { - maxConcurrencyDeadline, - maxInFlightReqsPerPeer, - blockFetchSize - } - fetchMode - nConcurrentFetchPeers - PeerFetchInFlightLimits { - inFlightBytesLowWatermark, - inFlightBytesHighWatermark - } - PeerFetchInFlight { - peerFetchReqsInFlight, - peerFetchBytesInFlight - } - peerFetchStatus - (Right fetchFragments) - - | peerFetchReqsInFlight >= maxInFlightReqsPerPeer - = Left $ FetchDeclineReqsInFlightLimit - maxInFlightReqsPerPeer - - | peerFetchBytesInFlight >= inFlightBytesHighWatermark - = Left $ FetchDeclineBytesInFlightLimit -- FIXME: this one should be maybe not too bad. - peerFetchBytesInFlight - inFlightBytesLowWatermark - inFlightBytesHighWatermark - - -- This covers the case when we could still fit in more reqs or bytes, but - -- we want to let it drop below a low water mark before sending more so we - -- get a bit more batching behaviour, rather than lots of 1-block reqs. - | peerFetchStatus == PeerFetchStatusBusy - = Left $ FetchDeclinePeerBusy -- FIXME: also not too bad - peerFetchBytesInFlight - inFlightBytesLowWatermark - inFlightBytesHighWatermark - - -- Refuse any blockrequest if we're above the concurrency limit. - | let maxConcurrentFetchPeers = case fetchMode of - FetchModeBulkSync -> 1 -- FIXME: maxConcurrencyBulkSync has to be removed from the interface - FetchModeDeadline -> maxConcurrencyDeadline - , nConcurrentFetchPeers > maxConcurrentFetchPeers - = Left $ FetchDeclineConcurrencyLimit - fetchMode maxConcurrentFetchPeers - - -- If we're at the concurrency limit refuse any additional peers. - | peerFetchReqsInFlight == 0 - , let maxConcurrentFetchPeers = case fetchMode of - FetchModeBulkSync -> 1 -- FIXME: maxConcurrencyBulkSync has to be removed from the interface - FetchModeDeadline -> maxConcurrencyDeadline - , nConcurrentFetchPeers == maxConcurrentFetchPeers - = Left $ FetchDeclineConcurrencyLimit - fetchMode maxConcurrentFetchPeers - - -- We've checked our request limit and our byte limit. We are then - -- guaranteed to get at least one non-empty request range. - | otherwise - = assert (peerFetchReqsInFlight < maxInFlightReqsPerPeer) $ - assert (not (null fetchFragments)) $ - - Right $ selectBlocksUpToLimits - blockFetchSize - peerFetchReqsInFlight - maxInFlightReqsPerPeer - peerFetchBytesInFlight - inFlightBytesHighWatermark - fetchFragments - --- | --- --- Precondition: The result will be non-empty if --- --- Property: result is non-empty if preconditions satisfied --- -selectBlocksUpToLimits - :: forall header. HasHeader header - => (header -> SizeInBytes) -- ^ Block body size - -> Word -- ^ Current number of requests in flight - -> Word -- ^ Maximum number of requests in flight allowed - -> SizeInBytes -- ^ Current number of bytes in flight - -> SizeInBytes -- ^ Maximum number of bytes in flight allowed - -> [AnchoredFragment header] - -> FetchRequest header -selectBlocksUpToLimits blockFetchSize nreqs0 maxreqs nbytes0 maxbytes fragments = - assert (nreqs0 < maxreqs && nbytes0 < maxbytes && not (null fragments)) $ - -- The case that we are already over our limits has to be checked earlier, - -- outside of this function. From here on however we check for limits. - - let fragments' = goFrags nreqs0 nbytes0 fragments in - assert (all (not . AF.null) fragments') $ - FetchRequest fragments' - where - goFrags :: Word - -> SizeInBytes - -> [AnchoredFragment header] -> [AnchoredFragment header] - goFrags _ _ [] = [] - goFrags nreqs nbytes (c:cs) - | nreqs+1 > maxreqs = [] - | otherwise = goFrag (nreqs+1) nbytes (Empty (AF.anchor c)) c cs - -- Each time we have to pick from a new discontiguous chain fragment then - -- that will become a new request, which contributes to our in-flight - -- request count. We never break the maxreqs limit. - - goFrag :: Word - -> SizeInBytes - -> AnchoredFragment header - -> AnchoredFragment header - -> [AnchoredFragment header] -> [AnchoredFragment header] - goFrag nreqs nbytes c' (Empty _) cs = c' : goFrags nreqs nbytes cs - goFrag nreqs nbytes c' (b :< c) cs - | nbytes' >= maxbytes = [c' :> b] - | otherwise = goFrag nreqs nbytes' (c' :> b) c cs - where - nbytes' = nbytes + blockFetchSize b - -- Note that we always pick the one last block that crosses the maxbytes - -- limit. This cover the case where we otherwise wouldn't even be able to - -- request a single block, as it's too large. diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index 03d1c43805e..dc071aef87c 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -7,26 +7,24 @@ -- | This module contains the part of the block fetch decisions process that is -- specific to the deadline mode. -module Ouroboros.Network.BlockFetch.Decision.Deadline - ( -- * Deciding what to fetch - fetchDecisionsDeadline - -- ** Components of the decision-making process - , prioritisePeerChains - , fetchRequestDecisions - ) where - -import Data.Set qualified as Set +module Ouroboros.Network.BlockFetch.Decision.Deadline where +import Control.Exception (assert) +import Control.Monad.Class.MonadTime.SI (DiffTime) import Data.Function (on) import Data.Hashable import Data.List (foldl', groupBy, sortBy, transpose) +import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Stack (HasCallStack) import Control.Monad (guard) -import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import Ouroboros.Network.AnchoredFragment (AnchoredSeq (..), AnchoredFragment) import Ouroboros.Network.AnchoredFragment qualified as AF +import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..)) import Ouroboros.Network.Block import Ouroboros.Network.Point (withOriginToMaybe) @@ -34,10 +32,204 @@ import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) import Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..), SizeInBytes, calculatePeerFetchInFlightLimits, - comparePeerGSV, comparePeerGSV', estimateExpectedResponseDuration, - estimateResponseDeadlineProbability) + comparePeerGSV, comparePeerGSV', estimateResponseDeadlineProbability) + + +data FetchDecisionPolicy header = FetchDecisionPolicy { + maxInFlightReqsPerPeer :: Word, -- A protocol constant. + + maxConcurrencyBulkSync :: Word, + maxConcurrencyDeadline :: Word, + decisionLoopInterval :: DiffTime, + peerSalt :: Int, + bulkSyncGracePeriod :: DiffTime, + + plausibleCandidateChain :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header -> Bool, + + compareCandidateChains :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header + -> Ordering, + + blockFetchSize :: header -> SizeInBytes + } + +type PeerInfo header peer extra = + ( PeerFetchStatus header, + PeerFetchInFlight header, + PeerGSV, + peer, + extra + ) + +-- | Throughout the decision making process we accumulate reasons to decline +-- to fetch any blocks. This type is used to wrap intermediate and final +-- results. +-- +type FetchDecision result = Either FetchDecline result + +-- | All the various reasons we can decide not to fetch blocks from a peer. +-- +-- It is worth highlighting which of these reasons result from competition +-- among upstream peers. +-- +-- * 'FetchDeclineInFlightOtherPeer': decline this peer because all the +-- unfetched blocks of its candidate chain have already been requested from +-- other peers. This reason reflects the least-consequential competition +-- among peers: the competition that determines merely which upstream peer to +-- burden with the request (eg the one with the best +-- 'Ouroboros.Network.BlockFetch.DeltaQ.DeltaQ' metrics). The consequences +-- are relatively minor because the unfetched blocks on this peer's candidate +-- chain will be requested regardless; it's merely a question of "From who?". +-- (One exception: if an adversarial peer wins this competition such that the +-- blocks are only requested from them, then it may be possible that this +-- decision determines whether the blocks are ever /received/. But that +-- depends on details of timeouts, a longer competing chain being soon +-- received within those timeouts, and so on.) +-- +-- * 'FetchDeclineChainNotPlausible': decline this peer because the node has +-- already fetched, validated, and selected a chain better than its candidate +-- chain from other peers (or from the node's own block forge). Because the +-- node's current selection is influenced by what blocks other peers have +-- recently served (or it recently minted), this reason reflects that peers +-- /indirectly/ compete by serving as long of a chain as possible and as +-- promptly as possible. When the tips of the peers' selections are all +-- within their respective forecast horizons (see +-- 'Ouroboros.Consensus.Ledger.SupportsProtocol.ledgerViewForecastAt'), then +-- the length of their candidate chains will typically be the length of their +-- selections, since the ChainSync is free to race ahead (in contrast, the +-- BlockFetch pipeline depth is bounded such that it will, for a syncing +-- node, not be able to request all blocks between the selection and the end +-- of the forecast window). But if one or more of their tips is beyond the +-- horizon, then the relative length of the candidate chains is more +-- complicated, influenced by both the relative density of the chains' +-- suffixes and the relative age of the chains' intersection with the node's +-- selection (since each peer's forecast horizon is a fixed number of slots +-- after the candidate's successor of that intersection). +-- +-- * 'FetchDeclineConcurrencyLimit': decline this peer while the node has +-- already fully allocated the artificially scarce 'maxConcurrentFetchPeers' +-- resource amongst its other peers. This reason reflects the +-- least-fundamental competition: it's the only way a node would decline a +-- candidate chain C that it would immediately switch to if C had somehow +-- already been fetched (and any better current candidates hadn't). It is +-- possible that this peer's candidate fragment is better than the candidate +-- fragments of other peers, but that should only happen ephemerally (eg for +-- a brief while immediately after first connecting to this peer). +-- +-- * 'FetchDeclineChainIntersectionTooDeep': decline this peer because the node's +-- selection has more than @K@ blocks that are not on this peer's candidate +-- chain. Typically, this reason occurs after the node has been declined---ie +-- lost the above competitions---for a long enough duration. This decision +-- only arises if the BlockFetch decision logic wins a harmless race against +-- the ChainSync client once the node's selection gets longer, since +-- 'Ouroboros.Consensus.MiniProtocol.ChainSync.Client.ForkTooDeep' +-- disconnects from such a peer. +-- +data FetchDecline = + -- | This peer's candidate chain is not longer than our chain. For more + -- details see + -- 'Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface.mkBlockFetchConsensusInterface' + -- which implements 'plausibleCandidateChain'. + -- + FetchDeclineChainNotPlausible + + -- | Switching to this peer's candidate chain would require rolling back + -- more than @K@ blocks. + -- + | FetchDeclineChainIntersectionTooDeep + + -- | Every block on this peer's candidate chain has already been fetched. + -- + | FetchDeclineAlreadyFetched + + -- | This peer's candidate chain has already been requested from this + -- peer. + -- + | FetchDeclineInFlightThisPeer + + -- | Some blocks on this peer's candidate chain have not yet been fetched, + -- but all of those have already been requested from other peers. + -- + | FetchDeclineInFlightOtherPeer + + -- | This peer's BlockFetch client is shutting down, see + -- 'PeerFetchStatusShutdown'. + -- + | FetchDeclinePeerShutdown + + -- | Blockfetch is starting up and waiting on corresponding Chainsync. + | FetchDeclinePeerStarting + + + -- The reasons above this comment are fundamental and/or obvious. On the + -- other hand, the reasons below are heuristic. + + + -- | This peer is in a potentially-temporary state in which it has not + -- responded to us within a certain expected time limit, see + -- 'PeerFetchStatusAberrant'. + -- + | FetchDeclinePeerSlow + + -- | This peer is not under the 'maxInFlightReqsPerPeer' limit. + -- + -- The argument is the 'maxInFlightReqsPerPeer' constant. + -- + | FetchDeclineReqsInFlightLimit !Word + + -- | This peer is not under the 'inFlightBytesHighWatermark' bytes limit. + -- + -- The arguments are: + -- + -- * number of bytes currently in flight for that peer + -- * the configured 'inFlightBytesLowWatermark' constant + -- * the configured 'inFlightBytesHighWatermark' constant + -- + | FetchDeclineBytesInFlightLimit !SizeInBytes !SizeInBytes !SizeInBytes + + -- | This peer is not under the 'inFlightBytesLowWatermark'. + -- + -- The arguments are: + -- + -- * number of bytes currently in flight for that peer + -- * the configured 'inFlightBytesLowWatermark' constant + -- * the configured 'inFlightBytesHighWatermark' constant + -- + | FetchDeclinePeerBusy !SizeInBytes !SizeInBytes !SizeInBytes + + -- | The node is not under the 'maxConcurrentFetchPeers' limit. + -- + -- The arguments are: + -- + -- * the current 'FetchMode' + -- * the corresponding configured limit constant, either + -- 'maxConcurrencyBulkSync' or 'maxConcurrencyDeadline' + -- + | FetchDeclineConcurrencyLimit !FetchMode !Word + deriving (Eq, Show) + +-- | The \"oh noes?!\" operator. +-- +-- In the case of an error, the operator provides a specific error value. +-- +(?!) :: Maybe a -> e -> Either e a +Just x ?! _ = Right x +Nothing ?! e = Left e + +-- | The combination of a 'ChainSuffix' and a list of discontiguous +-- 'AnchoredFragment's: +-- +-- * When comparing two 'CandidateFragments' as candidate chains, we use the +-- 'ChainSuffix'. +-- +-- * To track which blocks of that candidate still have to be downloaded, we +-- use a list of discontiguous 'AnchoredFragment's. +-- +type CandidateFragments header = (ChainSuffix header, [AnchoredFragment header]) -import Ouroboros.Network.BlockFetch.Decision.Common fetchDecisionsDeadline :: (Ord peer, @@ -68,11 +260,7 @@ fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { . map swizzleSIG -- Reorder chains based on consensus policy and network timing data. - . prioritisePeerChains - FetchModeDeadline - peerSalt - compareCandidateChains - blockFetchSize + . prioritisePeerChains peerSalt compareCandidateChains blockFetchSize . map swizzleIG -- Filter to keep blocks that are not already in-flight for this peer. @@ -98,6 +286,104 @@ fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { swizzleIG (c, p@(_, inflight,gsvs,peer,_)) = (c, inflight, gsvs, peer, p) swizzleSIG (c, p@(status,inflight,gsvs,peer,_)) = (c, status, inflight, gsvs, peer, p) +{- +We have the node's /current/ or /adopted/ chain. This is the node's chain in +the sense specified by the Ouroboros algorithm. It is a fully verified chain +with block bodies and a ledger state. + + ┆ ┆ + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ │ + ───┴───┴─── current chain length (block number) + +With chain selection we are interested in /candidate/ chains. We have these +candidate chains in the form of chains of verified headers, but without bodies. + +The consensus layer gives us the current set of candidate chains from our peers +and we have the task of selecting which block bodies to download, and then +passing those block bodes back to the consensus layer. The consensus layer will +try to validate them and decide if it wants to update its current chain. + + ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ └───┘ + │ │ │ │ │ │ │ │ + ───┴───┴─────┼───┼─────┼───┼─────┼───┼───────────── current chain length + │ │ │ │ │ │ + current ├───┤ ├───┤ └───┘ + (blocks) │ │ │ │ + └───┘ └───┘ + A B C D + candidates + (headers) + +In this example we have four candidate chains, with all but chain D strictly +longer than our current chain. + +In general there are many candidate chains. We make a distinction between a +candidate chain and the peer from which it is available. It is often the +case that the same chain is available from multiple peers. We will try to be +clear about when we are referring to chains or the combination of a chain and +the peer from which it is available. + +For the sake of the example let us assume we have the four chains above +available from the following peers. + +peer 1 2 3 4 5 6 7 + ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ ┆ + ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ │ │ │ │ + ├───┤ ├───┤ ├───┤ ├───┤ └───┘ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ │ │ + ──┼───┼─────┼───┼─────┼───┼─────┼───┼───────────────┼───┼─────┼───┼── + │ │ │ │ │ │ │ │ │ │ │ │ + └───┘ ├───┤ ├───┤ ├───┤ ├───┤ ├───┤ + │ │ │ │ │ │ │ │ │ │ + └───┘ └───┘ └───┘ └───┘ └───┘ +chain C A B A D B A + +This is the form in which we are informed about candidate chains from the +consensus layer, the combination of a chain and the peer it is from. This +makes sense, since these things change independently. + +We will process the chains in this form, keeping the peer/chain combination all +the way through. Although there could in principle be some opportunistic saving +by sharing when multiple peers provide the same chain, taking advantage of this +adds complexity and does nothing to improve our worst case costs. + +We are only interested in candidate chains that are strictly longer than our +current chain. So our first task is to filter down to this set. +-} + +-- | Keep only those candidate chains that are preferred over the current +-- chain. Typically, this means that their length is longer than the length of +-- the current chain. +-- +filterPlausibleCandidates + :: (AnchoredFragment block -> AnchoredFragment header -> Bool) + -> AnchoredFragment block -- ^ The current chain + -> [(AnchoredFragment header, peerinfo)] + -> [(FetchDecision (AnchoredFragment header), peerinfo)] +filterPlausibleCandidates plausibleCandidateChain currentChain chains = + [ (chain', peer) + | (chain, peer) <- chains + , let chain' = do + guard (plausibleCandidateChain currentChain chain) + ?! FetchDeclineChainNotPlausible + return chain + ] + {- In the example, this leaves us with only the candidate chains: A, B and C, but still paired up with the various peers. @@ -117,7 +403,44 @@ peer 1 2 3 4 6 7 chain C A B A B A -} +{- +Of course we would at most need to download the blocks in a candidate chain +that are not already in the current chain. So we must find those intersections. + +Before we do that, lets define how we represent a suffix of a chain. We do this +very simply as a chain fragment: exactly those blocks contained in the suffix. +A chain fragment is of course not a chain, but has many similar invariants. + +We will later also need to represent chain ranges when we send block fetch +requests. We do this using a pair of points: the first and last blocks in the +range. While we can represent an empty chain fragment, we cannot represent an +empty fetch range, but this is ok since we never request empty ranges. + Chain fragment + ┌───┐ + │ ◉ │ Start of range, inclusive + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ │ + ├───┤ + │ ◉ │ End of range, inclusive. + └───┘ +-} + +-- | A chain suffix, obtained by intersecting a candidate chain with the +-- current chain. +-- +-- The anchor point of a 'ChainSuffix' will be a point within the bounds of +-- the current chain ('AF.withinFragmentBounds'), indicating that it forks off +-- in the last @K@ blocks. +-- +-- A 'ChainSuffix' must be non-empty, as an empty suffix, i.e. the candidate +-- chain is equal to the current chain, would not be a plausible candidate. +newtype ChainSuffix header = + ChainSuffix { getChainSuffix :: AnchoredFragment header } {- We define the /chain suffix/ as the suffix of the candidate chain up until (but @@ -150,14 +473,179 @@ blocks. This means the candidate forks by more than K and so we are not interested in this candidate at all. -} +-- | Find the chain suffix for a candidate chain, with respect to the +-- current chain. +-- +chainForkSuffix + :: (HasHeader header, HasHeader block, + HeaderHash header ~ HeaderHash block) + => AnchoredFragment block -- ^ Current chain. + -> AnchoredFragment header -- ^ Candidate chain + -> Maybe (ChainSuffix header) +chainForkSuffix current candidate = + case AF.intersect current candidate of + Nothing -> Nothing + Just (_, _, _, candidateSuffix) -> + -- If the suffix is empty, it means the candidate chain was equal to + -- the current chain and didn't fork off. Such a candidate chain is + -- not a plausible candidate, so it must have been filtered out. + assert (not (AF.null candidateSuffix)) $ + Just (ChainSuffix candidateSuffix) + +selectForkSuffixes + :: (HasHeader header, HasHeader block, + HeaderHash header ~ HeaderHash block) + => AnchoredFragment block + -> [(FetchDecision (AnchoredFragment header), peerinfo)] + -> [(FetchDecision (ChainSuffix header), peerinfo)] +selectForkSuffixes current chains = + [ (mchain', peer) + | (mchain, peer) <- chains + , let mchain' = do + chain <- mchain + chainForkSuffix current chain ?! FetchDeclineChainIntersectionTooDeep + ] + +{- +We define the /fetch range/ as the suffix of the fork range that has not yet +had its blocks downloaded and block content checked against the headers. + + ┆ ┆ + ├───┤ + │ │ + ├───┤ ┌───┐ + │ │ already │ │ + ├───┤ fetched ├───┤ + │ │ blocks │ │ + ├───┤ ├───┤ + │ │ │░◉░│ ◄ fetch range + ───┴───┴─────┬───┬─────┼───┼─── + │░◉░│ ◄ │░░░│ + └───┘ ├───┤ + │░◉░│ ◄ + └───┘ + +In earlier versions of this scheme we maintained and relied on the invariant +that the ranges of fetched blocks are backwards closed. This meant we never had +discontinuous ranges of fetched or not-yet-fetched blocks. This invariant does +simplify things somewhat by keeping the ranges continuous however it precludes +fetching ranges of blocks from different peers in parallel. + +We do not maintain any such invariant and so we have to deal with there being +gaps in the ranges we have already fetched or are yet to fetch. To keep the +tracking simple we do not track the ranges themselves, rather we track the set +of individual blocks without their relationship to each other. + +-} + +-- | Find the fragments of the chain suffix that we still need to fetch because +-- they are covering blocks that have not yet been fetched. +-- +-- Typically this is a single fragment forming a suffix of the chain, but in +-- the general case we can get a bunch of discontiguous chain fragments. +-- +-- See also 'filterNotAlreadyInFlightWithPeer'. +filterNotAlreadyFetched :: + (HasHeader header, HeaderHash header ~ HeaderHash block) => + (Point block -> Bool) -> + MaxSlotNo -> + ChainSuffix header -> + FetchDecision (CandidateFragments header) +filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo candidate = + if null fragments + then Left FetchDeclineAlreadyFetched + else Right (candidate, fragments) + where + fragments = filterWithMaxSlotNo notAlreadyFetched fetchedMaxSlotNo (getChainSuffix candidate) + notAlreadyFetched = not . alreadyDownloaded . castPoint . blockPoint + +filterNotAlreadyFetched' :: + (HasHeader header, HeaderHash header ~ HeaderHash block) => + (Point block -> Bool) -> + MaxSlotNo -> + [(FetchDecision (ChainSuffix header), peerinfo)] -> + [(FetchDecision (CandidateFragments header), peerinfo)] +filterNotAlreadyFetched' alreadyDownloaded fetchedMaxSlotNo = + map + ( \(mcandidate, peer) -> + ((filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo =<< mcandidate), peer) + ) + +-- | Find the fragments of the chain suffix that we still need to fetch because +-- they are covering blocks that are not currently in the process of being +-- fetched from this peer. +-- +-- Typically this is a single fragment forming a suffix of the chain, but in +-- the general case we can get a bunch of discontiguous chain fragments. +-- +-- See also 'filterNotAlreadyFetched' +filterNotAlreadyInFlightWithPeer :: + (HasHeader header) => + PeerFetchInFlight header -> + CandidateFragments header -> + FetchDecision (CandidateFragments header) +filterNotAlreadyInFlightWithPeer inflight (candidate, chainfragments) = + if null fragments + then Left FetchDeclineInFlightThisPeer + else Right (candidate, fragments) + where + fragments = concatMap (filterWithMaxSlotNo notAlreadyInFlight (peerFetchMaxSlotNo inflight)) chainfragments + notAlreadyInFlight b = blockPoint b `Map.notMember` peerFetchBlocksInFlight inflight + +filterNotAlreadyInFlightWithPeer' :: + (HasHeader header) => + [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, peerinfo)] -> + [(FetchDecision (CandidateFragments header), peerinfo)] +filterNotAlreadyInFlightWithPeer' = + map + ( \(mcandidatefragments, inflight, peer) -> + ((filterNotAlreadyInFlightWithPeer inflight =<< mcandidatefragments), peer) + ) + +-- | Filter a fragment. This is an optimised variant that will behave the same +-- as 'AnchoredFragment.filter' if the following precondition is satisfied: +-- +-- PRECONDITION: for all @hdr@ in the chain fragment: if @blockSlot hdr > +-- maxSlotNo@ then the predicate should not hold for any header after @hdr@ in +-- the chain fragment. +-- +-- For example, when filtering out already downloaded blocks from the +-- fragment, it does not make sense to keep filtering after having encountered +-- the highest slot number the ChainDB has seen so far: blocks with a greater +-- slot number cannot have been downloaded yet. When the candidate fragments +-- get far ahead of the current chain, e.g., @2k@ headers, this optimisation +-- avoids the linear cost of filtering these headers when we know in advance +-- they will all remain in the final fragment. In case the given slot number +-- is 'NoSlotNo', no filtering takes place, as there should be no matches +-- because we haven't downloaded any blocks yet. +-- +-- For example, when filtering out blocks already in-flight for the given +-- peer, the given @maxSlotNo@ can correspond to the block with the highest +-- slot number that so far has been in-flight for the given peer. When no +-- blocks have been in-flight yet, @maxSlotNo@ can be 'NoSlotNo', in which +-- case no filtering needs to take place, which makes sense, as there are no +-- blocks to filter out. Note that this is conservative: if a block is for +-- some reason multiple times in-flight (maybe it has to be redownloaded) and +-- the block's slot number matches the @maxSlotNo@, it will now be filtered +-- (while the filtering might previously have stopped before encountering the +-- block in question). This is fine, as the filter will now include the block, +-- because according to the filtering predicate, the block is not in-flight. +filterWithMaxSlotNo + :: forall header. HasHeader header + => (header -> Bool) + -> MaxSlotNo -- ^ @maxSlotNo@ + -> AnchoredFragment header + -> [AnchoredFragment header] +filterWithMaxSlotNo p maxSlotNo = + AF.filterWithStop p ((> maxSlotNo) . MaxSlotNo . blockSlot) + prioritisePeerChains :: forall extra header peer. ( HasHeader header , Hashable peer , Ord peer ) - => FetchMode - -> Int + => Int -> (AnchoredFragment header -> AnchoredFragment header -> Ordering) -> (header -> SizeInBytes) -> [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, @@ -165,7 +653,7 @@ prioritisePeerChains peer, extra )] -> [(FetchDecision [AnchoredFragment header], extra)] -prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSize = +prioritisePeerChains salt compareCandidateChains blockFetchSize = map (\(decision, peer) -> (fmap (\(_,_,fragment) -> fragment) decision, peer)) . concatMap ( concat @@ -217,32 +705,6 @@ prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSiz chainHeadPoint (_,ChainSuffix c,_) = AF.headPoint c -prioritisePeerChains FetchModeBulkSync salt compareCandidateChains blockFetchSize = - map (\(decision, peer) -> - (fmap (\(_, _, fragment) -> fragment) decision, peer)) - . sortBy (comparingFst - (comparingRight - (comparingPair - -- compare on preferred chain first, then duration - (compareCandidateChains `on` getChainSuffix) - compare - `on` - (\(duration, chain, _fragments) -> (chain, duration))))) - . map annotateDuration - . sortBy (\(_,_,a,ap,_) (_,_,b,bp,_) -> - comparePeerGSV' salt (a,ap) (b,bp)) - where - annotateDuration (Left decline, _, _, _, peer) = (Left decline, peer) - annotateDuration (Right (chain,fragments), inflight, gsvs, _, peer) = - (Right (duration, chain, fragments), peer) - where - -- TODO: consider if we should put this into bands rather than just - -- taking the full value. - duration = estimateExpectedResponseDuration - gsvs - (peerFetchBytesInFlight inflight) - (totalFetchSize blockFetchSize fragments) - totalFetchSize :: (header -> SizeInBytes) -> [AnchoredFragment header] -> SizeInBytes @@ -448,3 +910,151 @@ fetchRequestDecisions fetchDecisionPolicy fetchMode chains = case fetchMode of FetchModeBulkSync -> maxConcurrencyBulkSync fetchDecisionPolicy FetchModeDeadline -> maxConcurrencyDeadline fetchDecisionPolicy + +-- | +-- +-- This function _does not_ check if the peer is likely to have the blocks in +-- the ranges, it only compute a request that respect what the peer's current +-- status indicates on their ability to fulfill it. +fetchRequestDecision + :: HasHeader header + => FetchDecisionPolicy header + -> FetchMode + -> Word + -- ^ Number of concurrent fetch peers. Can be set to @0@ to bypass + -- concurrency limits. + -> PeerFetchInFlightLimits + -> PeerFetchInFlight header + -> PeerFetchStatus header + -> FetchDecision [AnchoredFragment header] + -> FetchDecision (FetchRequest header) + +fetchRequestDecision _ _ _ _ _ _ (Left decline) + = Left decline + +fetchRequestDecision _ _ _ _ _ PeerFetchStatusShutdown _ + = Left FetchDeclinePeerShutdown + +fetchRequestDecision _ _ _ _ _ PeerFetchStatusStarting _ + = Left FetchDeclinePeerStarting + +fetchRequestDecision _ _ _ _ _ PeerFetchStatusAberrant _ + = Left FetchDeclinePeerSlow + +fetchRequestDecision FetchDecisionPolicy { + maxConcurrencyDeadline, + maxInFlightReqsPerPeer, + blockFetchSize + } + fetchMode + nConcurrentFetchPeers + PeerFetchInFlightLimits { + inFlightBytesLowWatermark, + inFlightBytesHighWatermark + } + PeerFetchInFlight { + peerFetchReqsInFlight, + peerFetchBytesInFlight + } + peerFetchStatus + (Right fetchFragments) + + | peerFetchReqsInFlight >= maxInFlightReqsPerPeer + = Left $ FetchDeclineReqsInFlightLimit + maxInFlightReqsPerPeer + + | peerFetchBytesInFlight >= inFlightBytesHighWatermark + = Left $ FetchDeclineBytesInFlightLimit -- FIXME: this one should be maybe not too bad. + peerFetchBytesInFlight + inFlightBytesLowWatermark + inFlightBytesHighWatermark + + -- This covers the case when we could still fit in more reqs or bytes, but + -- we want to let it drop below a low water mark before sending more so we + -- get a bit more batching behaviour, rather than lots of 1-block reqs. + | peerFetchStatus == PeerFetchStatusBusy + = Left $ FetchDeclinePeerBusy -- FIXME: also not too bad + peerFetchBytesInFlight + inFlightBytesLowWatermark + inFlightBytesHighWatermark + + -- Refuse any blockrequest if we're above the concurrency limit. + | let maxConcurrentFetchPeers = case fetchMode of + FetchModeBulkSync -> 1 -- FIXME: maxConcurrencyBulkSync has to be removed from the interface + FetchModeDeadline -> maxConcurrencyDeadline + , nConcurrentFetchPeers > maxConcurrentFetchPeers + = Left $ FetchDeclineConcurrencyLimit + fetchMode maxConcurrentFetchPeers + + -- If we're at the concurrency limit refuse any additional peers. + | peerFetchReqsInFlight == 0 + , let maxConcurrentFetchPeers = case fetchMode of + FetchModeBulkSync -> 1 -- FIXME: maxConcurrencyBulkSync has to be removed from the interface + FetchModeDeadline -> maxConcurrencyDeadline + , nConcurrentFetchPeers == maxConcurrentFetchPeers + = Left $ FetchDeclineConcurrencyLimit + fetchMode maxConcurrentFetchPeers + + -- We've checked our request limit and our byte limit. We are then + -- guaranteed to get at least one non-empty request range. + | otherwise + = assert (peerFetchReqsInFlight < maxInFlightReqsPerPeer) $ + assert (not (null fetchFragments)) $ + + Right $ selectBlocksUpToLimits + blockFetchSize + peerFetchReqsInFlight + maxInFlightReqsPerPeer + peerFetchBytesInFlight + inFlightBytesHighWatermark + fetchFragments + +-- | +-- +-- Precondition: The result will be non-empty if +-- +-- Property: result is non-empty if preconditions satisfied +-- +selectBlocksUpToLimits + :: forall header. HasHeader header + => (header -> SizeInBytes) -- ^ Block body size + -> Word -- ^ Current number of requests in flight + -> Word -- ^ Maximum number of requests in flight allowed + -> SizeInBytes -- ^ Current number of bytes in flight + -> SizeInBytes -- ^ Maximum number of bytes in flight allowed + -> [AnchoredFragment header] + -> FetchRequest header +selectBlocksUpToLimits blockFetchSize nreqs0 maxreqs nbytes0 maxbytes fragments = + assert (nreqs0 < maxreqs && nbytes0 < maxbytes && not (null fragments)) $ + -- The case that we are already over our limits has to be checked earlier, + -- outside of this function. From here on however we check for limits. + + let fragments' = goFrags nreqs0 nbytes0 fragments in + assert (all (not . AF.null) fragments') $ + FetchRequest fragments' + where + goFrags :: Word + -> SizeInBytes + -> [AnchoredFragment header] -> [AnchoredFragment header] + goFrags _ _ [] = [] + goFrags nreqs nbytes (c:cs) + | nreqs+1 > maxreqs = [] + | otherwise = goFrag (nreqs+1) nbytes (Empty (AF.anchor c)) c cs + -- Each time we have to pick from a new discontiguous chain fragment then + -- that will become a new request, which contributes to our in-flight + -- request count. We never break the maxreqs limit. + + goFrag :: Word + -> SizeInBytes + -> AnchoredFragment header + -> AnchoredFragment header + -> [AnchoredFragment header] -> [AnchoredFragment header] + goFrag nreqs nbytes c' (Empty _) cs = c' : goFrags nreqs nbytes cs + goFrag nreqs nbytes c' (b :< c) cs + | nbytes' >= maxbytes = [c' :> b] + | otherwise = goFrag nreqs nbytes' (c' :> b) c cs + where + nbytes' = nbytes + blockFetchSize b + -- Note that we always pick the one last block that crosses the maxbytes + -- limit. This cover the case where we otherwise wouldn't even be able to + -- request a single block, as it's too large. From 7044561f22d538f4bd2511dc08197b5ac5af0aa2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 10:34:23 +0200 Subject: [PATCH 073/136] Rename `checkChangeOfCurrentPeer` to `maybeSetCurrentPeer` --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 74b6707e314..d36dce02f5f 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -114,7 +114,7 @@ fetchDecisionsBulkSyncM -- the peers order, then we have shifted our focus: we make the new peer our -- current one and we put back the previous current peer at the beginning of -- the queue; not the end, because it has not done anything wrong. - checkChangeOfCurrentPeer theDecision peersOrder + maybeSetCurrentPeer theDecision peersOrder pure $ map (first Right) (maybeToList theDecision) @@ -157,8 +157,8 @@ fetchDecisionsBulkSyncM pure peersOrder' _ -> pure peersOrder - checkChangeOfCurrentPeer :: Maybe (any, PeerInfo header peer extra) -> PeersOrder peer -> m () - checkChangeOfCurrentPeer theDecision PeersOrder {peersOrderCurrent, peersOrderOthers} = + maybeSetCurrentPeer :: Maybe (any, PeerInfo header peer extra) -> PeersOrder peer -> m () + maybeSetCurrentPeer theDecision PeersOrder {peersOrderCurrent, peersOrderOthers} = case theDecision of Just (_, (_, _, _, thePeer, _)) | Just thePeer /= peersOrderCurrent -> do From 7dd843423abeae5be34ea55bdc5c4b90d773ef0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 10:38:27 +0200 Subject: [PATCH 074/136] Better comment for `filterNotAlreadyInFlightWithPeer` --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index d36dce02f5f..f85abc864d1 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -416,8 +416,9 @@ fetchTheCandidate thePeer@(status, inflight, gsvs, _, _) thePeerCandidate = let theDecision = do - -- Keep blocks that have not already been downloaded or that are not - -- already in-flight with this peer. + -- Keep blocks that are not already in-flight with this peer. NOTE: We + -- already filtered most of them (and more), but now we also filter + -- out then ones that are in-flight AND ignored. fragments <- filterNotAlreadyInFlightWithPeer inflight =<< theFragments -- Trim the fragments to the peer's candidate, keeping only blocks that From f43032b1970c1343d1bd9c3e73f46def29d7fac0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 11:38:36 +0200 Subject: [PATCH 075/136] First draft documentation for BulkSync --- .../Network/BlockFetch/Decision/BulkSync.hs | 82 ++++++++++++++++++- 1 file changed, 80 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index f85abc864d1..8952790d463 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -5,8 +5,86 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} --- | This module contains the part of the block fetch decisions process that is --- specific to the bulk sync mode. +-- | BulkSync decision logic +-- +-- This module contains the part of the block fetch decisions process that is +-- specific to the bulk sync mode. This logic reuses parts of the logic for the +-- deadline mode, but it is inherently different. +-- +-- Natural language specification +-- ------------------------------ +-- +-- Definitions: +-- +-- - Let @inflight :: peer -> Set blk@ be the outstanding blocks, those that +-- have been requested and are expected to arrive but have not yet. +-- +-- - Let @inflightIgnored :: Set blk@ be the outstanding blocks that have been +-- ignored. We have that @inflightIgnored@ is included in the union for all +-- peer @p@ of @inflight(p)@. We name @inflightNonIgnored@ the difference. +-- +-- - Let @peersOrder@ be an order of preference among the peers. This order is +-- not set in stone and will evolve as we go. +-- +-- - Let @currentPeer :: Maybe peer@ be the “current peer” with which we are +-- interacting. If it exists, this peer must be the best according to +-- @peersOrder@, and the last fetch request must have been sent to them. +-- +-- - Let @currentStart :: Time@ be the latest time a fetch request was sent +-- while there were no outstanding blocks. +-- +-- - Let @gracePeriod@ be a small duration (eg. 10s), during which a “cold” peer +-- is allowed to warm up (eg. grow the TCP window) before being expected to +-- feed blocks faster than we can validate them. +-- +-- One iteration of this decision logic: +-- +-- - If @inflight@ is non-empty and the block validation component has idled at +-- any point after @currentStart@ plus @gracePeriod@, then the peer +-- @currentPeer@ has failed to promptly serve @inflight(currentPeer)@, and: +-- +-- - If @currentPeer@ is the ChainSync Jumping dynamo, then it must +-- immediately be replaced as the dynamo. +-- +-- - Assume @currentPeer@ will never finish replying to that fetch request and +-- add all of @inflight(currentPeer)@ to @inflightIgnored@. REVIEW: Nick's +-- description says to add all of @inflight@ (for all the peers) to +-- @inflightIgnored@, probably because it assumes/enforces that @inflight == +-- inflight(currentPeer)@, that is only the current peer is allowed to have +-- in-flight blocks. +-- +-- - Stop considering the peer “current” and make them the worst according to +-- the @peersOrder@. +-- +-- - Let @theCandidate :: AnchoredFragment (Header blk)@ be the best candidate +-- header chain among the ChainSync clients (eg. best raw tiebreaker among the +-- longest). +-- +-- - Let @grossRequest@ be the oldest blocks on @theCandidate@ that have not +-- already been downloaded, are not in @inflightNonIgnored@, and total less +-- than 20 mebibytes. +-- +-- - If @grossRequest@ is empty, then terminate this iteration. Otherwise, pick +-- the best peer (according to @peersOrder@) offering all of the blocks in +-- @grossRequest@. We will call it @thePeer@. Because @currentPeer@, if it +-- exists, is the best according to @peersOrder@, then it will be our +-- preferred peer, as long as it can provide the @grossRequest@s. +-- +-- - If the byte size of @inflight(thePeer)@ is below the low-water mark, then +-- terminate this iteration. Otherwise, decide and send the actual next batch +-- request, as influenced by exactly which blocks are actually already +-- currently in-flight with the chosen peer. +-- +-- - Update @currentPeer@ and @currentStart@, if needed. Namely: +-- +-- - If @thePeer /= currentPeer@, then make @thePeer@ the current peer and the +-- best according to @peersOrder@, and reset @currentStart@ to now. +-- +-- - If @thePeer == currentPeer@, but @inflight(thePeer)@ is empty, the reset +-- @currentStart@ to now. +-- +-- Terminate this iteration. +-- module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM ) where From bc4451ea1496eccdea767d3e27fcbbde5a3f58a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 11:46:12 +0200 Subject: [PATCH 076/136] Re-record a new start time when no inflight blocks --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 8952790d463..b00e0548a72 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -240,6 +240,9 @@ fetchDecisionsBulkSyncM case theDecision of Just (_, (_, _, _, thePeer, _)) | Just thePeer /= peersOrderCurrent -> do + -- We chose a new peer: set the new peer as current, record a + -- new start time, and push the previous “current peer”, if any, + -- into the other peers. peersOrderStart <- getMonotonicTime writePeersOrder $ PeersOrder @@ -247,6 +250,11 @@ fetchDecisionsBulkSyncM peersOrderStart, peersOrderOthers = mcons peersOrderCurrent (filter (/= thePeer) peersOrderOthers) } + | not (peerHasBlocksInFlight thePeer) -> do + -- We chose the same peer as before but there were no more + -- blocks in flight for this peer: record a new start time. + peersOrderStart <- getMonotonicTime + writePeersOrder $ PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} _ -> pure () peerHasBlocksInFlight peer = From 40ec6bc8533450b8e35356742dcfbdddb12bd834 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 11:46:29 +0200 Subject: [PATCH 077/136] Switch gross request to 20 mebibytes --- .../Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index b00e0548a72..081fd2c3c40 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -424,9 +424,9 @@ selectThePeer peersOrder theFragments candidates = do - -- Create a fetch request for the blocks in question. The request is made - -- to fit in 1MB but ignores everything else. It is gross in that sense. - -- It will only be used to choose the peer to fetch from, but we will + -- Create a fetch request for the blocks in question. The request is made to + -- fit in 20 mebibytes but ignores everything else. It is gross in that + -- sense. It will only be used to choose the peer to fetch from, but we will -- later craft a more refined request for that peer. let (grossRequest :: FetchDecision (FetchRequest header)) = selectBlocksUpToLimits @@ -434,13 +434,13 @@ selectThePeer 0 -- number of request in flight maxBound -- maximum number of requests in flight 0 -- bytes in flight - (1024 * 1024) -- maximum bytes in flight; one megabyte + (20 * 1000 * 1000) -- maximum bytes in flight; 20 mebibyte . snd <$> theFragments -- For each peer, check whether its candidate contains the gross request in -- its entirety, otherwise decline it. This will guarantee that the - -- remaining peers can serve the refine request that we will craft later. + -- remaining peers can serve the refined request that we will craft later. peers <- filterM ( \(candidate, peer) -> From 4438847da447e65494860ef02dbe1b2d142dbdf7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 11:52:33 +0200 Subject: [PATCH 078/136] Document on `grossRequest`'s non-emptiness --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 081fd2c3c40..bdb320638dc 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -311,7 +311,8 @@ fetchDecisionsBulkSync -- Step 2: Filter out from the chosen candidate fragment the blocks that -- have already been downloaded, or that have a request in flight (except - -- for the requests in flight that are ignored). + -- for the requests in flight that are ignored). NOTE: if not declined, + -- @theFragments@ is guaranteed to be non-empty. let (theFragments :: FetchDecision (CandidateFragments header)) = pure theCandidate >>= filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo @@ -403,6 +404,7 @@ selectTheCandidate -- the ordering passed as argument. -- -- PRECONDITION: The set of peers must be included in the peer order queue. +-- PRECONDITION: The given candidate fragments must not be empty. selectThePeer :: forall header peer extra. ( HasHeader header, @@ -427,7 +429,8 @@ selectThePeer -- Create a fetch request for the blocks in question. The request is made to -- fit in 20 mebibytes but ignores everything else. It is gross in that -- sense. It will only be used to choose the peer to fetch from, but we will - -- later craft a more refined request for that peer. + -- later craft a more refined request for that peer. Because @theFragments@ + -- is not empty, @grossRequest@ will not be empty. let (grossRequest :: FetchDecision (FetchRequest header)) = selectBlocksUpToLimits blockFetchSize From d615b8f433274daebdba8ce3e41020e6e883b2f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 11:53:10 +0200 Subject: [PATCH 079/136] Remove useless `FIXME` --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index bdb320638dc..46ed7c89d83 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -347,9 +347,6 @@ fetchDecisionsBulkSync ) combineWithDeclined = second listConcatToList . runWithDeclined . runMaybeT --- FIXME: The 'FetchDeclineConcurrencyLimit' should only be used for --- 'FetchModeDeadline', and 'FetchModeBulkSync' should have its own reasons. - -- | Given a list of candidate fragments and their associated peers, select the -- candidate to sync from. Return this fragment, the list of peers that are -- still in race to serve it, and the list of peers that are already being From 2ca7b8bcaeb94dce69d796a382c28f23eda0d121 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 12:08:52 +0200 Subject: [PATCH 080/136] `fetchDecisions` (mind the s) is only used by `FetchModeDeadline` --- .../Network/BlockFetch/Decision/BulkSync.hs | 2 +- .../Network/BlockFetch/Decision/Deadline.hs | 35 +++---------------- 2 files changed, 6 insertions(+), 31 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 46ed7c89d83..c60dfea8a51 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -519,7 +519,7 @@ fetchTheCandidate (calculatePeerFetchInFlightLimits gsvs) inflight status - (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecisions'. + (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecision'. in case theDecision of Left reason -> tell (List [(reason, thePeer)]) >> pure Nothing Right theRequest -> pure $ Just (theRequest, thePeer) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index dc071aef87c..28d9dea26a3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -254,9 +254,7 @@ fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { fetchedMaxSlotNo = -- Finally, make a decision for each (chain, peer) pair. - fetchRequestDecisions - fetchDecisionPolicy - FetchModeDeadline + fetchRequestDecisions fetchDecisionPolicy . map swizzleSIG -- Reorder chains based on consensus policy and network timing data. @@ -800,7 +798,6 @@ fetchRequestDecisions , Ord peer ) => FetchDecisionPolicy header - -> FetchMode -> [( FetchDecision [AnchoredFragment header] , PeerFetchStatus header , PeerFetchInFlight header @@ -808,7 +805,7 @@ fetchRequestDecisions , peer , extra)] -> [(FetchDecision (FetchRequest header), extra)] -fetchRequestDecisions fetchDecisionPolicy fetchMode chains = +fetchRequestDecisions fetchDecisionPolicy chains = go nConcurrentFetchPeers0 Set.empty NoMaxSlotNo chains where go :: Word @@ -827,30 +824,14 @@ fetchRequestDecisions fetchDecisionPolicy fetchMode chains = where decision = fetchRequestDecision fetchDecisionPolicy - fetchMode + FetchModeDeadline -- Permit the preferred peers to by pass any concurrency limits. (if elem peer nPreferedPeers then 0 else nConcurrentFetchPeers) (calculatePeerFetchInFlightLimits gsvs) inflight status - mchainfragments' - - mchainfragments' = - case fetchMode of - FetchModeDeadline -> mchainfragments - FetchModeBulkSync -> do - chainfragments <- mchainfragments - let fragments = - concatMap (filterWithMaxSlotNo - notFetchedThisRound - maxSlotNoFetchedThisRound) - chainfragments - guard (not (null fragments)) ?! FetchDeclineInFlightOtherPeer - return fragments - where - notFetchedThisRound h = - blockPoint h `Set.notMember` blocksFetchedThisRound + mchainfragments nConcurrentFetchPeers' -- increment if it was idle, and now will not be @@ -900,17 +881,11 @@ fetchRequestDecisions fetchDecisionPolicy fetchMode chains = nPreferedPeers :: [peer] nPreferedPeers = map snd - . take (fromIntegral maxConcurrentFetchPeers) + . take (fromIntegral $ maxConcurrencyDeadline fetchDecisionPolicy) . sortBy (\a b -> comparePeerGSV nActivePeers (peerSalt fetchDecisionPolicy) a b) . map (\(_, _, _, gsv, p, _) -> (gsv, p)) $ chains - maxConcurrentFetchPeers :: Word - maxConcurrentFetchPeers = - case fetchMode of - FetchModeBulkSync -> maxConcurrencyBulkSync fetchDecisionPolicy - FetchModeDeadline -> maxConcurrencyDeadline fetchDecisionPolicy - -- | -- -- This function _does not_ check if the peer is likely to have the blocks in From 9f338a4502fa9972d0651bb26c3a8acb10328c98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 12:11:34 +0200 Subject: [PATCH 081/136] Remove unused argument `maxConcurrencyBulkSync` --- ouroboros-network/demo/chain-sync.hs | 1 - .../sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs | 2 -- .../sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs | 1 - ouroboros-network/src/Ouroboros/Network/BlockFetch.hs | 4 ---- .../src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs | 7 +++---- .../src/Ouroboros/Network/Diffusion/Configuration.hs | 1 - 6 files changed, 3 insertions(+), 13 deletions(-) diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index f702484ace5..0ac3ec4da8b 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -511,7 +511,6 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do blockFetchPolicy registry (BlockFetchConfiguration { - bfcMaxConcurrencyBulkSync = 1, bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, diff --git a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs index 1a1a8d08489..b3b4e472d60 100644 --- a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -135,7 +135,6 @@ blockFetchExample0 decisionTracer clientStateTracer clientMsgTracer (sampleBlockFetchPolicy1 headerForgeUTCTime blockHeap currentChainHeaders candidateChainHeaders) registry (BlockFetchConfiguration { - bfcMaxConcurrencyBulkSync = 1, bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, @@ -245,7 +244,6 @@ blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer (sampleBlockFetchPolicy1 headerForgeUTCTime blockHeap currentChainHeaders candidateChainHeaders) registry (BlockFetchConfiguration { - bfcMaxConcurrencyBulkSync = 1, bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs index faa38b73255..0f23d99daff 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -291,7 +291,6 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = (blockFetchPolicy nodeKernel) (nkFetchClientRegistry nodeKernel) (BlockFetchConfiguration { - bfcMaxConcurrencyBulkSync = 1, bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index 9bb3ca63cf9..010ad28b024 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -128,9 +128,6 @@ import Ouroboros.Network.BlockFetch.State -- Should be determined by external local node config. data BlockFetchConfiguration = BlockFetchConfiguration { - -- | Maximum concurrent downloads during bulk syncing. - bfcMaxConcurrencyBulkSync :: !Word, - -- | Maximum concurrent downloads during deadline syncing. bfcMaxConcurrencyDeadline :: !Word, @@ -199,7 +196,6 @@ blockFetchLogic decisionTracer clientStateTracer fetchDecisionPolicy = FetchDecisionPolicy { maxInFlightReqsPerPeer = bfcMaxRequestsInflight, - maxConcurrencyBulkSync = bfcMaxConcurrencyBulkSync, maxConcurrencyDeadline = bfcMaxConcurrencyDeadline, decisionLoopInterval = bfcDecisionLoopInterval, peerSalt = bfcSalt, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index 28d9dea26a3..8e5156e13f3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -38,7 +38,6 @@ import Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..), SizeInBytes, calculate data FetchDecisionPolicy header = FetchDecisionPolicy { maxInFlightReqsPerPeer :: Word, -- A protocol constant. - maxConcurrencyBulkSync :: Word, maxConcurrencyDeadline :: Word, decisionLoopInterval :: DiffTime, peerSalt :: Int, @@ -206,7 +205,7 @@ data FetchDecline = -- -- * the current 'FetchMode' -- * the corresponding configured limit constant, either - -- 'maxConcurrencyBulkSync' or 'maxConcurrencyDeadline' + -- 'maxConcurrencyDeadline', or 1 for bulk sync. -- | FetchDeclineConcurrencyLimit !FetchMode !Word deriving (Eq, Show) @@ -955,7 +954,7 @@ fetchRequestDecision FetchDecisionPolicy { -- Refuse any blockrequest if we're above the concurrency limit. | let maxConcurrentFetchPeers = case fetchMode of - FetchModeBulkSync -> 1 -- FIXME: maxConcurrencyBulkSync has to be removed from the interface + FetchModeBulkSync -> 1 FetchModeDeadline -> maxConcurrencyDeadline , nConcurrentFetchPeers > maxConcurrentFetchPeers = Left $ FetchDeclineConcurrencyLimit @@ -964,7 +963,7 @@ fetchRequestDecision FetchDecisionPolicy { -- If we're at the concurrency limit refuse any additional peers. | peerFetchReqsInFlight == 0 , let maxConcurrentFetchPeers = case fetchMode of - FetchModeBulkSync -> 1 -- FIXME: maxConcurrencyBulkSync has to be removed from the interface + FetchModeBulkSync -> 1 FetchModeDeadline -> maxConcurrencyDeadline , nConcurrentFetchPeers == maxConcurrentFetchPeers = Left $ FetchDeclineConcurrencyLimit diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index 119ea20e08b..e3da98cc8a2 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -91,7 +91,6 @@ defaultPeerSharing = PeerSharingDisabled defaultBlockFetchConfiguration :: Int -> BlockFetchConfiguration defaultBlockFetchConfiguration bfcSalt = BlockFetchConfiguration { - bfcMaxConcurrencyBulkSync = 1, bfcMaxConcurrencyDeadline = 1, bfcMaxRequestsInflight = fromIntegral $ blockFetchPipeliningMax defaultMiniProtocolParameters, bfcDecisionLoopInterval = 0.01, -- 10ms From 4205e6853fed5410512fbf9dc7c7aa4bf70f41c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 12:28:32 +0200 Subject: [PATCH 082/136] Document the interaction with CSJ --- .../Network/BlockFetch/Decision/BulkSync.hs | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index c60dfea8a51..5fddeaf4202 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -85,6 +85,26 @@ -- -- Terminate this iteration. -- +-- Interactions with ChainSync Jumping (CSJ) +-- ----------------------------------------- +-- +-- This decision logic is not so obviously coupled with CSJ, but it is in some +-- subtle ways: +-- +-- - Because we always require our peers to be able to serve a gross request of +-- oldest blocks, peers with longer chains have a better chance to pass this +-- criteria and to be selected as current peer. The CSJ dynamo, being always +-- ahead of jumpers, has therefore more chances to be selected as the current +-- peer. It is still possible for a jumper or a disengaged peer to be +-- selected. +-- +-- - If the current peer is the CSJ dynamo, but it is a dishonest peer serving +-- headers fast but retaining headers, it might be able to drastically leash +-- us, because its ChainSync client will be stuck behind the forecast horizon +-- (and therefore not subject to ChainSync punishments such as the Limit on +-- Patience). This is why we need to consider starvation of ChainSel and +-- demote peers that let us starve. +-- module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM ) where From 04be7c4a8c7f9093db1e5514a2d83f6f2b8ceed5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 12:34:20 +0200 Subject: [PATCH 083/136] Add documentation about the gross request --- .../Network/BlockFetch/Decision/BulkSync.hs | 23 +++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 5fddeaf4202..6fc491d5fce 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -105,6 +105,24 @@ -- Patience). This is why we need to consider starvation of ChainSel and -- demote peers that let us starve. -- +-- About the gross request +-- ----------------------- +-- +-- Morally, we want to select a peer that is able to serve us a batch of oldest +-- blocks of @theCandidate@. However, the actual requests depend not only on the +-- size of the blocks to fetch, but also on the network performances of the peer +-- and what requests it already has in-flight. Looking at what peer can create +-- an actual request for @theCandidate@ can be misleading: indeed, our +-- @currentPeer@ might not be able to create a request simply because it is +-- already busy answering other requests from us. This calls for the +-- introduction of an objective criterium, which the gross request provides. +-- +-- If the gross request is included in a peer's candidate, it means that this +-- peer can serve at least the first 20 mebibytes of the blocks that we wish to +-- fetch. The actual request might be smaller than that, depending on the actual +-- in-flight limits, but it might also be bigger because the peer can have more +-- blocks than just those. +-- module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM ) where @@ -446,8 +464,9 @@ selectThePeer -- Create a fetch request for the blocks in question. The request is made to -- fit in 20 mebibytes but ignores everything else. It is gross in that -- sense. It will only be used to choose the peer to fetch from, but we will - -- later craft a more refined request for that peer. Because @theFragments@ - -- is not empty, @grossRequest@ will not be empty. + -- later craft a more refined request for that peer. See [About the gross + -- request] in the module documentation. Because @theFragments@ is not + -- empty, @grossRequest@ will not be empty. let (grossRequest :: FetchDecision (FetchRequest header)) = selectBlocksUpToLimits blockFetchSize From e5db153b4f87f3b31f954e160e45f2162065575d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 12:40:04 +0200 Subject: [PATCH 084/136] Mebibytes, not megabytes --- --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 6fc491d5fce..5567bc1c388 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -473,7 +473,7 @@ selectThePeer 0 -- number of request in flight maxBound -- maximum number of requests in flight 0 -- bytes in flight - (20 * 1000 * 1000) -- maximum bytes in flight; 20 mebibyte + (20 * 1024 * 1024) -- maximum bytes in flight; 20 mebibyte . snd <$> theFragments From 4ec07782d7cbf1f2224022809859d265c164b6aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 19:31:38 +0200 Subject: [PATCH 085/136] Ignore all blocks in flight when demoting --- .../src/Ouroboros/Network/BlockFetch/State.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 2aa52117f4b..11d4b1ecf52 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -17,6 +17,7 @@ module Ouroboros.Network.BlockFetch.State , TraceFetchClientState (..) ) where +import Data.Foldable (for_) import Data.Functor.Contravariant (contramap) import Data.Hashable (Hashable) import Data.Map.Strict (Map) @@ -24,6 +25,7 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Void +import Control.Concurrent.Class.MonadSTM.Strict.TVar (modifyTVar) import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked (newTVarIO, StrictTVar, readTVarIO, writeTVar) import Control.Exception (assert) import Control.Monad.Class.MonadSTM @@ -44,7 +46,6 @@ import Ouroboros.Network.BlockFetch.Decision (FetchDecision, PeerInfo, fetchDecisions) import Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation) -import Control.Concurrent.Class.MonadSTM.Strict.TVar (modifyTVar) fetchLogicIterations @@ -181,14 +182,11 @@ fetchLogicIteration decisionTracer clientStateTracer demoteCSJDynamo peer atomically $ do peerStateVars <- readStatePeerStateVars fetchNonTriggerVariables - case Map.lookup peer peerStateVars of - Nothing -> return () - Just peerStateVar -> - modifyTVar (fetchClientInFlightVar peerStateVar) $ \pfif -> - pfif - { peerFetchBlocksInFlight = - fmap (const (PeerFetchBlockInFlight True)) (peerFetchBlocksInFlight pfif) - } + for_ peerStateVars $ \peerStateVar -> + modifyTVar (fetchClientInFlightVar peerStateVar) $ \pfif -> + pfif { peerFetchBlocksInFlight = + fmap (const (PeerFetchBlockInFlight True)) (peerFetchBlocksInFlight pfif) + } -- | Do a bit of rearranging of data before calling 'fetchDecisions' to do the -- real work. From d35ab47f838297ae3d3e73acab4224d4ad51af9c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Fri, 12 Jul 2024 19:39:14 +0200 Subject: [PATCH 086/136] Keep using the same peer until it starves us --- .../Network/BlockFetch/ClientState.hs | 10 +- .../Network/BlockFetch/Decision/BulkSync.hs | 175 +++++++++--------- .../src/Ouroboros/Network/BlockFetch/State.hs | 3 +- 3 files changed, 94 insertions(+), 94 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index 3720c2ecdf8..977f8df9ff2 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -809,13 +809,11 @@ tryReadTMergeVar (TMergeVar v) = tryReadTMVar v -- | The order of peers for bulk sync fetch decisions. -- --- We could merge the current peer into the list of others, but we keep them --- separate to make sure that we always consider it separately. +-- FIXME: peersOrderStart would make much more sense as part of the in-flight +-- stuff. data PeersOrder peer = PeersOrder - { peersOrderOthers :: [peer] - -- ^ All the other peers, from most preferred to least preferred. - , peersOrderCurrent :: Maybe peer - -- ^ The current peer that we are talking to. + { peersOrderAll :: [peer] + -- ^ All the peers, from most preferred to least preferred. , peersOrderStart :: Time -- ^ The time at which we started talking to that peer. } diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 5567bc1c388..8f7ad9aa6a9 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -127,17 +127,18 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM ) where -import Control.Monad (filterM) +import Control.Exception (assert) +import Control.Monad (filterM, when) import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime), addTime) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) import Data.Foldable (foldl') -import Data.List (sortOn, find) +import qualified Data.List as List import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe, maybeToList) +import Data.Maybe (mapMaybe, maybeToList, fromJust) import qualified Data.Set as Set import Data.Ord (Down(Down)) @@ -146,7 +147,7 @@ import Cardano.Prelude (guard, partitionEithers, (&)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), mcons, PeerFetchBlockInFlight (..), PeerFetchStatus (..), PeerFetchInFlight (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), PeerFetchBlockInFlight (..), PeerFetchStatus (..), PeerFetchInFlight (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) @@ -226,11 +227,11 @@ fetchDecisionsBulkSyncM peersOrder candidatesAndPeers - -- If the peer that is supposed to fetch the block is not the current one in - -- the peers order, then we have shifted our focus: we make the new peer our - -- current one and we put back the previous current peer at the beginning of - -- the queue; not the end, because it has not done anything wrong. - maybeSetCurrentPeer theDecision peersOrder + -- If there were no blocks in flight, then this will be the first request, + -- so we take a new current time. + when (List.null peersWithBlocksInFlightNonIgnored) $ do + peersOrderStart <- getMonotonicTime + writePeersOrder $ peersOrder {peersOrderStart} pure $ map (first Right) (maybeToList theDecision) @@ -239,70 +240,41 @@ fetchDecisionsBulkSyncM alignPeersOrderWithActualPeers :: [peer] -> PeersOrder peer -> PeersOrder peer alignPeersOrderWithActualPeers actualPeers - PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = - let peersOrderCurrent' = case peersOrderCurrent of - Just peersOrderCurrent_ | peersOrderCurrent_ `elem` actualPeers -> peersOrderCurrent - _ -> Nothing - peersOrderOthers' = - filter (`elem` actualPeers) peersOrderOthers - ++ filter (\peer -> peer `notElem` peersOrderOthers && Just peer /= peersOrderCurrent) actualPeers + PeersOrder {peersOrderStart, peersOrderAll} = + let peersOrderAll' = + filter (`elem` actualPeers) peersOrderAll + ++ filter (\peer -> peer `notElem` peersOrderAll) actualPeers in PeersOrder - { peersOrderCurrent = peersOrderCurrent', - peersOrderOthers = peersOrderOthers', + { peersOrderAll = peersOrderAll', peersOrderStart } checkLastChainSelStarvation :: PeersOrder peer -> m (PeersOrder peer) checkLastChainSelStarvation - peersOrder@PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} = do + peersOrder@PeersOrder {peersOrderStart, peersOrderAll} = do lastStarvationTime <- case chainSelStarvation of ChainSelStarvationEndedAt time -> pure time ChainSelStarvationOngoing -> getMonotonicTime - case peersOrderCurrent of - Just peersOrderCurrent_ - | peerHasBlocksInFlight peersOrderCurrent_ - && lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart -> + case peersWithBlocksInFlightNonIgnored of + (_, _, _, badPeer, _) : _ + | lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart -> do + demoteCSJDynamoAndIgnoreInflightBlocks badPeer let peersOrder' = PeersOrder - { peersOrderCurrent = Nothing, - peersOrderOthers = snoc peersOrderOthers peersOrderCurrent_, + { peersOrderAll = filter (/= badPeer) peersOrderAll ++ [badPeer], peersOrderStart } - demoteCSJDynamoAndIgnoreInflightBlocks peersOrderCurrent_ + writePeersOrder peersOrder' pure peersOrder' _ -> pure peersOrder - maybeSetCurrentPeer :: Maybe (any, PeerInfo header peer extra) -> PeersOrder peer -> m () - maybeSetCurrentPeer theDecision PeersOrder {peersOrderCurrent, peersOrderOthers} = - case theDecision of - Just (_, (_, _, _, thePeer, _)) - | Just thePeer /= peersOrderCurrent -> do - -- We chose a new peer: set the new peer as current, record a - -- new start time, and push the previous “current peer”, if any, - -- into the other peers. - peersOrderStart <- getMonotonicTime - writePeersOrder $ - PeersOrder - { peersOrderCurrent = Just thePeer, - peersOrderStart, - peersOrderOthers = mcons peersOrderCurrent (filter (/= thePeer) peersOrderOthers) - } - | not (peerHasBlocksInFlight thePeer) -> do - -- We chose the same peer as before but there were no more - -- blocks in flight for this peer: record a new start time. - peersOrderStart <- getMonotonicTime - writePeersOrder $ PeersOrder {peersOrderCurrent, peersOrderStart, peersOrderOthers} - _ -> pure () - - peerHasBlocksInFlight peer = - case find (\(_, (_, _, _, peer', _)) -> peer == peer') candidatesAndPeers of - Just (_, (_, inflight, _, _, _)) -> not $ Map.null $ peerFetchBlocksInFlight inflight - Nothing -> error "blocksInFlightForPeer" - -snoc :: [a] -> a -> [a] -snoc [] a = [a] -snoc (x : xs) a = x : snoc xs a + peersWithBlocksInFlightNonIgnored = + filter + ( \(_, inflight, _, _, _) -> + not $ Map.null $ Map.filter (\(PeerFetchBlockInFlight b) -> not b) $ peerFetchBlocksInFlight inflight + ) + (map snd candidatesAndPeers) -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. @@ -416,7 +388,7 @@ selectTheCandidate . filterPlausibleCandidates plausibleCandidateChain currentChain -- Sort the candidates by descending block number of their heads, that is -- consider longest fragments first. - . sortOn (Down . headBlockNo . fst) + . List.sortOn (Down . headBlockNo . fst) where -- Very ad-hoc helper. -- Write all of the declined peers, and find the candidate fragment @@ -477,35 +449,53 @@ selectThePeer . snd <$> theFragments - -- For each peer, check whether its candidate contains the gross request in - -- its entirety, otherwise decline it. This will guarantee that the - -- remaining peers can serve the refined request that we will craft later. - peers <- - filterM - ( \(candidate, peer) -> - case checkRequestInCandidate candidate =<< grossRequest of - Left reason -> tell (List [(reason, peer)]) >> pure False - Right () -> pure True - ) - candidates - - -- Order the peers according to the peer order that we have been given, then - -- separate between declined peers and the others. NOTE: The order in which - -- we bind the lists in the comprehension is capital. - let peersOrdered = - [ (candidate, peerInfo) - | peer' <- mcons (peersOrderCurrent peersOrder) (peersOrderOthers peersOrder), - (candidate, peerInfo@(_, _, _, peer, _)) <- peers, - peer == peer' - ] - - -- Return the first peer in that order, and decline all the ones that were - -- not already declined. - case peersOrdered of - [] -> return Nothing - (thePeerCandidate, thePeer) : otherPeers -> do - tell $ List $ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers - return $ Just (thePeerCandidate, thePeer) + -- If there are peers with blocks that are in-flight and not ignored, then + -- there must actually be just the one and that is the one we choose. If + -- there are no peers with blocks in-flight (except maybe ignored), then we + -- can choose any peer, so we choose a “good” one. + case peersWithBlocksInFlightNonIgnored of + + (_, _, _, thePeer, _) : theOtherPeersWithBlocksInFlightNonIgnored -> + assert (List.null theOtherPeersWithBlocksInFlightNonIgnored) $ do + let ((thePeerCandidate, thePeerInfo), otherPeers) = fromJust $ extractFirstElem (\(_, (_, _, _, peer, _)) -> peer == thePeer) candidates + tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers)) + -- REVIEW: This is maybe overkill to check that the whole gross request + -- fits in the peer's candidate. Maybe just checking that there is one + -- block is sufficient. + case checkRequestInCandidate thePeerCandidate =<< grossRequest of + Left reason -> tell (List [(reason, thePeerInfo)]) >> return Nothing + Right () -> return $ Just (thePeerCandidate, thePeerInfo) + + [] -> do + -- For each peer, check whether its candidate contains the gross request in + -- its entirety, otherwise decline it. This will guarantee that the + -- remaining peers can serve the refined request that we will craft later. + peers <- + filterM + ( \(candidate, peer) -> + case checkRequestInCandidate candidate =<< grossRequest of + Left reason -> tell (List [(reason, peer)]) >> pure False + Right () -> pure True + ) + candidates + + -- Order the peers according to the peer order that we have been given, then + -- separate between declined peers and the others. NOTE: The order in which + -- we bind the lists in the comprehension is capital. + let peersOrdered = + [ (candidate, peerInfo) + | peer' <- peersOrderAll peersOrder, + (candidate, peerInfo@(_, _, _, peer, _)) <- peers, + peer == peer' + ] + + -- Return the first peer in that order, and decline all the ones that were + -- not already declined. + case peersOrdered of + [] -> return Nothing + (thePeerCandidate, thePeer) : otherPeers -> do + tell $ List $ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers + return $ Just (thePeerCandidate, thePeer) where checkRequestInCandidate :: ChainSuffix header -> FetchRequest header -> FetchDecision () @@ -518,6 +508,13 @@ selectThePeer AF.withinFragmentBounds (AF.anchorPoint fragment) (getChainSuffix candidate) && AF.withinFragmentBounds (AF.headPoint fragment) (getChainSuffix candidate) + peersWithBlocksInFlightNonIgnored = + filter + ( \(_, inflight, _, _, _) -> + not $ Map.null $ Map.filter (\(PeerFetchBlockInFlight b) -> not b) $ peerFetchBlocksInFlight inflight + ) + (map snd candidates) + -- | Given a candidate and a peer to sync from, create a request for that -- specific peer. We might take the 'FetchDecision' to decline the request, but -- only for “good” reasons, eg. if the peer is already too busy. @@ -611,3 +608,9 @@ filterNotAlreadyInFlightWithAnyPeerNonIgnored candidates theCandidate = do max NoMaxSlotNo [peerFetchMaxSlotNo inflight | (_, (_, inflight, _, _, _)) <- candidates] + +extractFirstElem :: (a -> Bool) -> [a] -> Maybe (a, [a]) +extractFirstElem _ [] = Nothing +extractFirstElem p (x : xs) + | p x = Just (x, xs) + | otherwise = second (x :) <$> extractFirstElem p xs diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 11d4b1ecf52..c695cd9ee54 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -71,9 +71,8 @@ fetchLogicIterations decisionTracer clientStateTracer demoteCSJDynamo = do peersOrderVar <- newTVarIO $ PeersOrder { - peersOrderCurrent = Nothing, peersOrderStart = Time 0, - peersOrderOthers = [] + peersOrderAll = [] } iterateForever initialFetchStateFingerprint $ \stateFingerprint -> do From 90084d4365f5f1d0665474ad31435db9357ec1a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Sat, 13 Jul 2024 00:07:49 +0200 Subject: [PATCH 087/136] Avoid having two slightly-different notions of current peers --- .../Network/BlockFetch/Decision/BulkSync.hs | 53 +++++++++++-------- 1 file changed, 32 insertions(+), 21 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 8f7ad9aa6a9..afef8ff8e57 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -225,11 +225,12 @@ fetchDecisionsBulkSyncM fetchedBlocks fetchedMaxSlotNo peersOrder + mCurrentPeer candidatesAndPeers -- If there were no blocks in flight, then this will be the first request, -- so we take a new current time. - when (List.null peersWithBlocksInFlightNonIgnored) $ do + when (mCurrentPeer == Nothing) $ do peersOrderStart <- getMonotonicTime writePeersOrder $ peersOrder {peersOrderStart} @@ -255,10 +256,10 @@ fetchDecisionsBulkSyncM lastStarvationTime <- case chainSelStarvation of ChainSelStarvationEndedAt time -> pure time ChainSelStarvationOngoing -> getMonotonicTime - case peersWithBlocksInFlightNonIgnored of - (_, _, _, badPeer, _) : _ - | lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart -> - do + case mCurrentPeer of + Just badPeer -> + if lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart + then do demoteCSJDynamoAndIgnoreInflightBlocks badPeer let peersOrder' = PeersOrder @@ -267,14 +268,21 @@ fetchDecisionsBulkSyncM } writePeersOrder peersOrder' pure peersOrder' - _ -> pure peersOrder - - peersWithBlocksInFlightNonIgnored = - filter - ( \(_, inflight, _, _, _) -> - not $ Map.null $ Map.filter (\(PeerFetchBlockInFlight b) -> not b) $ peerFetchBlocksInFlight inflight - ) - (map snd candidatesAndPeers) + else pure peersOrder + Nothing -> pure peersOrder + + mCurrentPeer = + let peersWithBlocksInFlightNonIgnored = + filter + ( \(_, inflight, _, _, _) -> + not $ Map.null $ Map.filter (\(PeerFetchBlockInFlight b) -> not b) $ peerFetchBlocksInFlight inflight + ) + (map snd candidatesAndPeers) + in case peersWithBlocksInFlightNonIgnored of + (_, _, _, peer, _) : otherPeersWithBlocksInFlightNonIgnored -> + assert (List.null otherPeersWithBlocksInFlightNonIgnored) $ + Just peer + _ -> Nothing -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. @@ -289,6 +297,8 @@ fetchDecisionsBulkSync :: (Point block -> Bool) -> MaxSlotNo -> PeersOrder peer -> + -- | The current peer, if there is one. + Maybe peer -> -- | Association list of the candidate fragments and their associated peers. -- The candidate fragments are anchored in the current chain (not necessarily -- at the tip; and not necessarily forking off immediately). @@ -306,6 +316,7 @@ fetchDecisionsBulkSync fetchedBlocks fetchedMaxSlotNo peersOrder + mCurrentPeer candidatesAndPeers = combineWithDeclined $ do -- Step 1: Select the candidate to sync from. This already eliminates peers -- that have an implausible candidate. It returns the remaining candidates @@ -338,6 +349,7 @@ fetchDecisionsBulkSync selectThePeer fetchDecisionPolicy peersOrder + mCurrentPeer theFragments candidatesAndPeers' @@ -419,6 +431,8 @@ selectThePeer :: ) => FetchDecisionPolicy header -> PeersOrder peer -> + -- | The current peer + Maybe peer -> -- | The candidate fragment that we have selected to sync from, as suffix of -- the immutable tip. FetchDecision (CandidateFragments header) -> @@ -431,6 +445,7 @@ selectThePeer :: selectThePeer FetchDecisionPolicy {blockFetchSize} peersOrder + mCurrentPeer theFragments candidates = do -- Create a fetch request for the blocks in question. The request is made to @@ -449,14 +464,10 @@ selectThePeer . snd <$> theFragments - -- If there are peers with blocks that are in-flight and not ignored, then - -- there must actually be just the one and that is the one we choose. If - -- there are no peers with blocks in-flight (except maybe ignored), then we + -- If there is a current peer, then that is the one we choose. Otherwise, we -- can choose any peer, so we choose a “good” one. - case peersWithBlocksInFlightNonIgnored of - - (_, _, _, thePeer, _) : theOtherPeersWithBlocksInFlightNonIgnored -> - assert (List.null theOtherPeersWithBlocksInFlightNonIgnored) $ do + case mCurrentPeer of + Just thePeer -> do let ((thePeerCandidate, thePeerInfo), otherPeers) = fromJust $ extractFirstElem (\(_, (_, _, _, peer, _)) -> peer == thePeer) candidates tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers)) -- REVIEW: This is maybe overkill to check that the whole gross request @@ -466,7 +477,7 @@ selectThePeer Left reason -> tell (List [(reason, thePeerInfo)]) >> return Nothing Right () -> return $ Just (thePeerCandidate, thePeerInfo) - [] -> do + Nothing -> do -- For each peer, check whether its candidate contains the gross request in -- its entirety, otherwise decline it. This will guarantee that the -- remaining peers can serve the refined request that we will craft later. From 4c84463e375f190bb149d53184d62ccfbc35917e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Sat, 13 Jul 2024 00:25:59 +0200 Subject: [PATCH 088/136] Last fixes --- .../Network/BlockFetch/Decision/BulkSync.hs | 44 +++++++++---------- 1 file changed, 21 insertions(+), 23 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index afef8ff8e57..fac503d58b3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -138,7 +138,7 @@ import qualified Data.List as List import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe, maybeToList, fromJust) +import Data.Maybe (mapMaybe, maybeToList, isNothing) import qualified Data.Set as Set import Data.Ord (Down(Down)) @@ -230,7 +230,7 @@ fetchDecisionsBulkSyncM -- If there were no blocks in flight, then this will be the first request, -- so we take a new current time. - when (mCurrentPeer == Nothing) $ do + when (isNothing mCurrentPeer) $ do peersOrderStart <- getMonotonicTime writePeersOrder $ peersOrder {peersOrderStart} @@ -257,7 +257,7 @@ fetchDecisionsBulkSyncM ChainSelStarvationEndedAt time -> pure time ChainSelStarvationOngoing -> getMonotonicTime case mCurrentPeer of - Just badPeer -> + Just (_,_,_,badPeer,_) -> if lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart then do demoteCSJDynamoAndIgnoreInflightBlocks badPeer @@ -279,9 +279,9 @@ fetchDecisionsBulkSyncM ) (map snd candidatesAndPeers) in case peersWithBlocksInFlightNonIgnored of - (_, _, _, peer, _) : otherPeersWithBlocksInFlightNonIgnored -> + peerInfo : otherPeersWithBlocksInFlightNonIgnored -> assert (List.null otherPeersWithBlocksInFlightNonIgnored) $ - Just peer + Just peerInfo _ -> Nothing -- | Given a list of candidate fragments and their associated peers, choose what @@ -298,7 +298,7 @@ fetchDecisionsBulkSync :: MaxSlotNo -> PeersOrder peer -> -- | The current peer, if there is one. - Maybe peer -> + Maybe (PeerInfo header peer extra) -> -- | Association list of the candidate fragments and their associated peers. -- The candidate fragments are anchored in the current chain (not necessarily -- at the tip; and not necessarily forking off immediately). @@ -432,7 +432,7 @@ selectThePeer :: FetchDecisionPolicy header -> PeersOrder peer -> -- | The current peer - Maybe peer -> + Maybe (PeerInfo header peer extra) -> -- | The candidate fragment that we have selected to sync from, as suffix of -- the immutable tip. FetchDecision (CandidateFragments header) -> @@ -467,15 +467,17 @@ selectThePeer -- If there is a current peer, then that is the one we choose. Otherwise, we -- can choose any peer, so we choose a “good” one. case mCurrentPeer of - Just thePeer -> do - let ((thePeerCandidate, thePeerInfo), otherPeers) = fromJust $ extractFirstElem (\(_, (_, _, _, peer, _)) -> peer == thePeer) candidates - tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers)) - -- REVIEW: This is maybe overkill to check that the whole gross request - -- fits in the peer's candidate. Maybe just checking that there is one - -- block is sufficient. - case checkRequestInCandidate thePeerCandidate =<< grossRequest of - Left reason -> tell (List [(reason, thePeerInfo)]) >> return Nothing - Right () -> return $ Just (thePeerCandidate, thePeerInfo) + Just thePeerInfo -> do + case extractFirstElem (eqPeerInfo thePeerInfo . snd) candidates of + Nothing -> tell (List [(FetchDeclineChainNotPlausible, thePeerInfo)]) >> return Nothing + Just ((thePeerCandidate, _), otherPeers) -> do + tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers)) + -- REVIEW: This is maybe overkill to check that the whole gross request + -- fits in the peer's candidate. Maybe just checking that there is one + -- block is sufficient. + case checkRequestInCandidate thePeerCandidate =<< grossRequest of + Left reason -> tell (List [(reason, thePeerInfo)]) >> return Nothing + Right () -> return $ Just (thePeerCandidate, thePeerInfo) Nothing -> do -- For each peer, check whether its candidate contains the gross request in @@ -519,13 +521,6 @@ selectThePeer AF.withinFragmentBounds (AF.anchorPoint fragment) (getChainSuffix candidate) && AF.withinFragmentBounds (AF.headPoint fragment) (getChainSuffix candidate) - peersWithBlocksInFlightNonIgnored = - filter - ( \(_, inflight, _, _, _) -> - not $ Map.null $ Map.filter (\(PeerFetchBlockInFlight b) -> not b) $ peerFetchBlocksInFlight inflight - ) - (map snd candidates) - -- | Given a candidate and a peer to sync from, create a request for that -- specific peer. We might take the 'FetchDecision' to decline the request, but -- only for “good” reasons, eg. if the peer is already too busy. @@ -625,3 +620,6 @@ extractFirstElem _ [] = Nothing extractFirstElem p (x : xs) | p x = Just (x, xs) | otherwise = second (x :) <$> extractFirstElem p xs + +eqPeerInfo :: Eq peer => PeerInfo header peer extra -> PeerInfo header peer extra -> Bool +eqPeerInfo (_,_,_,p1,_) (_,_,_,p2,_) = p1 == p2 From 2d2d07a15bdc4f10fb4b66477bbceb3aebcf3d01 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 15 Jul 2024 13:12:01 +0200 Subject: [PATCH 089/136] A proper datatype for blockfetch decision tracing --- ouroboros-network/ouroboros-network.cabal | 1 + .../Ouroboros/Network/BlockFetch/Examples.hs | 7 +++---- .../sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs | 4 ++-- ouroboros-network/src/Ouroboros/Network/BlockFetch.hs | 3 ++- .../src/Ouroboros/Network/BlockFetch/Decision/Trace.hs | 10 ++++++++++ .../src/Ouroboros/Network/BlockFetch/State.hs | 8 ++++---- 6 files changed, 22 insertions(+), 11 deletions(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Trace.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 590da01ade3..bd538536838 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -35,6 +35,7 @@ library Ouroboros.Network.BlockFetch.Decision Ouroboros.Network.BlockFetch.Decision.BulkSync Ouroboros.Network.BlockFetch.Decision.Deadline + Ouroboros.Network.BlockFetch.Decision.Trace Ouroboros.Network.BlockFetch.DeltaQ Ouroboros.Network.BlockFetch.State Ouroboros.Network.DeltaQ diff --git a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs index b3b4e472d60..9518bb77d27 100644 --- a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -56,6 +56,7 @@ import Ouroboros.Network.Protocol.BlockFetch.Type import Ouroboros.Network.Util.ShowProxy import Ouroboros.Network.Mock.ConcreteBlock +import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) -- | Run a single block fetch protocol until the chain is downloaded. @@ -64,8 +65,7 @@ blockFetchExample0 :: forall m. (MonadSTM m, MonadST m, MonadAsync m, MonadDelay m, MonadFork m, MonadTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) - => Tracer m [TraceLabelPeer Int - (FetchDecision [Point BlockHeader])] + => Tracer m (TraceDecisionEvent Int BlockHeader) -> Tracer m (TraceLabelPeer Int (TraceFetchClientState BlockHeader)) -> Tracer m (TraceLabelPeer Int @@ -173,8 +173,7 @@ blockFetchExample1 :: forall m. (MonadSTM m, MonadST m, MonadAsync m, MonadDelay m, MonadFork m, MonadTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) - => Tracer m [TraceLabelPeer Int - (FetchDecision [Point BlockHeader])] + => Tracer m (TraceDecisionEvent Int BlockHeader) -> Tracer m (TraceLabelPeer Int (TraceFetchClientState BlockHeader)) -> Tracer m (TraceLabelPeer Int diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs index 60990c6cfeb..353b2adaaba 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs @@ -52,6 +52,7 @@ import Ouroboros.Network.NodeToNode.Version (isPipeliningEnabled) import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch) import Ouroboros.Network.Testing.Utils +import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) -- @@ -206,8 +207,7 @@ chainPoints = map (castPoint . blockPoint) . AnchoredFragment.toOldestFirst data Example1TraceEvent = - TraceFetchDecision [TraceLabelPeer Int - (FetchDecision [Point BlockHeader])] + TraceFetchDecision (TraceDecisionEvent Int BlockHeader) | TraceFetchClientState (TraceLabelPeer Int (TraceFetchClientState BlockHeader)) | TraceFetchClientSendRecv (TraceLabelPeer Int diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index 010ad28b024..25a49933890 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -121,6 +121,7 @@ import Ouroboros.Network.BlockFetch.ConsensusInterface (BlockFetchConsensusInterface (..), FromConsensus (..), WhetherReceivingTentativeBlocks (..)) import Ouroboros.Network.BlockFetch.State +import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) @@ -162,7 +163,7 @@ blockFetchLogic :: forall addr header block m. , Ord addr , Hashable addr ) - => Tracer m [TraceLabelPeer addr (FetchDecision [Point header])] + => Tracer m (TraceDecisionEvent addr header) -> Tracer m (TraceLabelPeer addr (TraceFetchClientState header)) -> BlockFetchConsensusInterface addr header block m -> FetchClientRegistry addr header block m diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Trace.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Trace.hs new file mode 100644 index 00000000000..423239b9339 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Trace.hs @@ -0,0 +1,10 @@ + +module Ouroboros.Network.BlockFetch.Decision.Trace where + +import Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer) +import Ouroboros.Network.Block (Point) +import Ouroboros.Network.BlockFetch.Decision.Deadline (FetchDecision) + +data TraceDecisionEvent peer header + = PeersFetch [TraceLabelPeer peer (FetchDecision [Point header])] + deriving (Show) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index c695cd9ee54..85ba1322de5 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -46,7 +46,7 @@ import Ouroboros.Network.BlockFetch.Decision (FetchDecision, PeerInfo, fetchDecisions) import Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation) - +import Ouroboros.Network.BlockFetch.Decision.Trace fetchLogicIterations :: ( HasHeader header @@ -57,7 +57,7 @@ fetchLogicIterations , Ord peer , Hashable peer ) - => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])] + => Tracer m (TraceDecisionEvent peer header) -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) -> FetchDecisionPolicy header -> FetchTriggerVariables peer header m @@ -113,7 +113,7 @@ fetchLogicIteration HasHeader header, HasHeader block, HeaderHash header ~ HeaderHash block, MonadMonotonicTime m) - => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])] + => Tracer m (TraceDecisionEvent peer header) -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) -> FetchDecisionPolicy header -> FetchTriggerVariables peer header m @@ -155,7 +155,7 @@ fetchLogicIteration decisionTracer clientStateTracer -- _ <- evaluate (force decisions) -- Trace the batch of fetch decisions - traceWith decisionTracer + traceWith decisionTracer $ PeersFetch [ TraceLabelPeer peer (fmap fetchRequestPoints decision) | (decision, (_, _, _, peer, _)) <- decisions ] From 8db3f2d74da28f68cfb367d6e0ab49ac7cbf6527 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 15 Jul 2024 13:56:21 +0200 Subject: [PATCH 090/136] Remove useless `filterNotAlreadyInFlightWithAny...` --- .../Network/BlockFetch/Decision/BulkSync.hs | 47 ++----------------- 1 file changed, 4 insertions(+), 43 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index fac503d58b3..ad60ac7c4a8 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -133,21 +133,19 @@ import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime), import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) import Data.Bifunctor (first, Bifunctor (..)) -import Data.Foldable (foldl') import qualified Data.List as List import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe, maybeToList, isNothing) -import qualified Data.Set as Set import Data.Ord (Down(Down)) -import Cardano.Prelude (guard, partitionEithers, (&)) +import Cardano.Prelude (partitionEithers, (&)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), PeerFetchBlockInFlight (..), PeerFetchStatus (..), PeerFetchInFlight (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), PeerFetchBlockInFlight (..), PeerFetchInFlight (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) @@ -331,13 +329,11 @@ fetchDecisionsBulkSync candidatesAndPeers -- Step 2: Filter out from the chosen candidate fragment the blocks that - -- have already been downloaded, or that have a request in flight (except - -- for the requests in flight that are ignored). NOTE: if not declined, - -- @theFragments@ is guaranteed to be non-empty. + -- have already been downloaded. NOTE: if not declined, @theFragments@ is + -- guaranteed to be non-empty. let (theFragments :: FetchDecision (CandidateFragments header)) = pure theCandidate >>= filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo - >>= filterNotAlreadyInFlightWithAnyPeerNonIgnored candidatesAndPeers -- Step 3: Select the peer to sync from. This eliminates peers that cannot -- serve a reasonable batch of the candidate, then chooses the peer to sync @@ -580,41 +576,6 @@ fetchTheCandidate then Left FetchDeclineAlreadyFetched else Right trimmedFragments -filterNotAlreadyInFlightWithAnyPeerNonIgnored :: - (HasHeader header) => - [(any, PeerInfo header peer extra)] -> - CandidateFragments header -> - FetchDecision (CandidateFragments header) -filterNotAlreadyInFlightWithAnyPeerNonIgnored candidates theCandidate = do - let theFragments = - concatMap - ( filterWithMaxSlotNo - notAlreadyInFlightNonIgnored - maxSlotNoInFlightWithPeers - ) - (snd theCandidate) - guard (not (null theFragments)) ?! FetchDeclineInFlightOtherPeer - return $ (fst theCandidate, theFragments) - where - notAlreadyInFlightNonIgnored b = - blockPoint b `Set.notMember` blocksInFlightWithPeersNonIgnored - -- All the blocks that are already in-flight with all peers and not ignored. - blocksInFlightWithPeersNonIgnored = - Set.unions - [ case status of - PeerFetchStatusShutdown -> Set.empty - PeerFetchStatusStarting -> Set.empty - PeerFetchStatusAberrant -> Set.empty - _other -> Map.keysSet $ Map.filter (\(PeerFetchBlockInFlight b) -> not b) $ peerFetchBlocksInFlight inflight - | (_, (status, inflight, _, _, _)) <- candidates - ] - -- The highest slot number that is or has been in flight for any peer. - maxSlotNoInFlightWithPeers = - foldl' - max - NoMaxSlotNo - [peerFetchMaxSlotNo inflight | (_, (_, inflight, _, _, _)) <- candidates] - extractFirstElem :: (a -> Bool) -> [a] -> Maybe (a, [a]) extractFirstElem _ [] = Nothing extractFirstElem p (x : xs) From 270c02e64a0702f0b05aead6c77fcb40aae371fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 15 Jul 2024 14:03:07 +0200 Subject: [PATCH 091/136] `filterNot` -> `drop` --- .../Ouroboros/Network/BlockFetch/Decision.hs | 6 ++-- .../Network/BlockFetch/Decision/BulkSync.hs | 4 +-- .../Network/BlockFetch/Decision/Deadline.hs | 30 +++++++++---------- 3 files changed, 20 insertions(+), 20 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index bffae41b904..f074c4d149d 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -16,8 +16,8 @@ module Ouroboros.Network.BlockFetch.Decision -- ** Components of the decision-making process , filterPlausibleCandidates , selectForkSuffixes - , filterNotAlreadyFetched - , filterNotAlreadyInFlightWithPeer + , dropAlreadyFetched + , dropAlreadyInFlightWithPeer , prioritisePeerChains , fetchRequestDecisions ) where @@ -31,7 +31,7 @@ import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder ( import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..), ChainSelStarvation) import Ouroboros.Network.BlockFetch.Decision.Deadline (FetchDecisionPolicy (..), PeerInfo, FetchDecision, FetchDecline (..), - filterPlausibleCandidates, filterNotAlreadyFetched, filterNotAlreadyInFlightWithPeer, + filterPlausibleCandidates, dropAlreadyFetched, dropAlreadyInFlightWithPeer, selectForkSuffixes, fetchDecisionsDeadline, prioritisePeerChains, fetchRequestDecisions) import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSyncM) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index ad60ac7c4a8..c747fbfc0e5 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -333,7 +333,7 @@ fetchDecisionsBulkSync -- guaranteed to be non-empty. let (theFragments :: FetchDecision (CandidateFragments header)) = pure theCandidate - >>= filterNotAlreadyFetched fetchedBlocks fetchedMaxSlotNo + >>= dropAlreadyFetched fetchedBlocks fetchedMaxSlotNo -- Step 3: Select the peer to sync from. This eliminates peers that cannot -- serve a reasonable batch of the candidate, then chooses the peer to sync @@ -543,7 +543,7 @@ fetchTheCandidate -- Keep blocks that are not already in-flight with this peer. NOTE: We -- already filtered most of them (and more), but now we also filter -- out then ones that are in-flight AND ignored. - fragments <- filterNotAlreadyInFlightWithPeer inflight =<< theFragments + fragments <- dropAlreadyInFlightWithPeer inflight =<< theFragments -- Trim the fragments to the peer's candidate, keeping only blocks that -- they may actually serve. diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index 8e5156e13f3..502dc72fc76 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -261,11 +261,11 @@ fetchDecisionsDeadline fetchDecisionPolicy@FetchDecisionPolicy { . map swizzleIG -- Filter to keep blocks that are not already in-flight for this peer. - . filterNotAlreadyInFlightWithPeer' + . dropAlreadyInFlightWithPeer' . map swizzleI -- Filter to keep blocks that have not already been downloaded. - . filterNotAlreadyFetched' + . dropAlreadyFetched' fetchedBlocks fetchedMaxSlotNo @@ -541,14 +541,14 @@ of individual blocks without their relationship to each other. -- Typically this is a single fragment forming a suffix of the chain, but in -- the general case we can get a bunch of discontiguous chain fragments. -- --- See also 'filterNotAlreadyInFlightWithPeer'. -filterNotAlreadyFetched :: +-- See also 'dropAlreadyInFlightWithPeer'. +dropAlreadyFetched :: (HasHeader header, HeaderHash header ~ HeaderHash block) => (Point block -> Bool) -> MaxSlotNo -> ChainSuffix header -> FetchDecision (CandidateFragments header) -filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo candidate = +dropAlreadyFetched alreadyDownloaded fetchedMaxSlotNo candidate = if null fragments then Left FetchDeclineAlreadyFetched else Right (candidate, fragments) @@ -556,16 +556,16 @@ filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo candidate = fragments = filterWithMaxSlotNo notAlreadyFetched fetchedMaxSlotNo (getChainSuffix candidate) notAlreadyFetched = not . alreadyDownloaded . castPoint . blockPoint -filterNotAlreadyFetched' :: +dropAlreadyFetched' :: (HasHeader header, HeaderHash header ~ HeaderHash block) => (Point block -> Bool) -> MaxSlotNo -> [(FetchDecision (ChainSuffix header), peerinfo)] -> [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyFetched' alreadyDownloaded fetchedMaxSlotNo = +dropAlreadyFetched' alreadyDownloaded fetchedMaxSlotNo = map ( \(mcandidate, peer) -> - ((filterNotAlreadyFetched alreadyDownloaded fetchedMaxSlotNo =<< mcandidate), peer) + ((dropAlreadyFetched alreadyDownloaded fetchedMaxSlotNo =<< mcandidate), peer) ) -- | Find the fragments of the chain suffix that we still need to fetch because @@ -575,13 +575,13 @@ filterNotAlreadyFetched' alreadyDownloaded fetchedMaxSlotNo = -- Typically this is a single fragment forming a suffix of the chain, but in -- the general case we can get a bunch of discontiguous chain fragments. -- --- See also 'filterNotAlreadyFetched' -filterNotAlreadyInFlightWithPeer :: +-- See also 'dropAlreadyFetched' +dropAlreadyInFlightWithPeer :: (HasHeader header) => PeerFetchInFlight header -> CandidateFragments header -> FetchDecision (CandidateFragments header) -filterNotAlreadyInFlightWithPeer inflight (candidate, chainfragments) = +dropAlreadyInFlightWithPeer inflight (candidate, chainfragments) = if null fragments then Left FetchDeclineInFlightThisPeer else Right (candidate, fragments) @@ -589,14 +589,14 @@ filterNotAlreadyInFlightWithPeer inflight (candidate, chainfragments) = fragments = concatMap (filterWithMaxSlotNo notAlreadyInFlight (peerFetchMaxSlotNo inflight)) chainfragments notAlreadyInFlight b = blockPoint b `Map.notMember` peerFetchBlocksInFlight inflight -filterNotAlreadyInFlightWithPeer' :: +dropAlreadyInFlightWithPeer' :: (HasHeader header) => [(FetchDecision (CandidateFragments header), PeerFetchInFlight header, peerinfo)] -> [(FetchDecision (CandidateFragments header), peerinfo)] -filterNotAlreadyInFlightWithPeer' = +dropAlreadyInFlightWithPeer' = map ( \(mcandidatefragments, inflight, peer) -> - ((filterNotAlreadyInFlightWithPeer inflight =<< mcandidatefragments), peer) + ((dropAlreadyInFlightWithPeer inflight =<< mcandidatefragments), peer) ) -- | Filter a fragment. This is an optimised variant that will behave the same @@ -840,7 +840,7 @@ fetchRequestDecisions fetchDecisionPolicy chains = -- This is only for avoiding duplication between fetch requests in this -- round of decisions. Avoiding duplication with blocks that are already - -- in flight is handled by filterNotAlreadyInFlightWithOtherPeers + -- in flight is handled by dropAlreadyInFlightWithOtherPeers (blocksFetchedThisRound', maxSlotNoFetchedThisRound') = case decision of Left _ -> From 4ba0e83c0c730bcb2db973ad18785e9d5dde575f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 15 Jul 2024 14:03:44 +0200 Subject: [PATCH 092/136] typos --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index c747fbfc0e5..c9b9e987c1b 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -80,7 +80,7 @@ -- - If @thePeer /= currentPeer@, then make @thePeer@ the current peer and the -- best according to @peersOrder@, and reset @currentStart@ to now. -- --- - If @thePeer == currentPeer@, but @inflight(thePeer)@ is empty, the reset +-- - If @thePeer == currentPeer@, but @inflight(thePeer)@ is empty, then reset -- @currentStart@ to now. -- -- Terminate this iteration. @@ -99,7 +99,7 @@ -- selected. -- -- - If the current peer is the CSJ dynamo, but it is a dishonest peer serving --- headers fast but retaining headers, it might be able to drastically leash +-- headers fast but retaining blocks, it might be able to drastically leash -- us, because its ChainSync client will be stuck behind the forecast horizon -- (and therefore not subject to ChainSync punishments such as the Limit on -- Patience). This is why we need to consider starvation of ChainSel and From 33ffeb3e611299b5dd22b65df2dd95a294e73ac2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Mon, 15 Jul 2024 14:32:47 +0200 Subject: [PATCH 093/136] Trace when peer starved us --- .../src/Ouroboros/Network/BlockFetch/Decision.hs | 8 +++++++- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 7 ++++++- .../src/Ouroboros/Network/BlockFetch/Decision/Trace.hs | 1 + .../src/Ouroboros/Network/BlockFetch/State.hs | 6 +++++- 4 files changed, 19 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index f074c4d149d..287b33969b4 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -24,6 +24,7 @@ module Ouroboros.Network.BlockFetch.Decision import Data.Hashable import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime(..)) +import Control.Tracer (Tracer) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block @@ -34,6 +35,7 @@ import Ouroboros.Network.BlockFetch.Decision.Deadline (FetchDecisionPolicy (..), filterPlausibleCandidates, dropAlreadyFetched, dropAlreadyInFlightWithPeer, selectForkSuffixes, fetchDecisionsDeadline, prioritisePeerChains, fetchRequestDecisions) import Ouroboros.Network.BlockFetch.Decision.BulkSync (fetchDecisionsBulkSyncM) +import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) fetchDecisions :: forall peer header block m extra. @@ -41,7 +43,8 @@ fetchDecisions Hashable peer, HasHeader header, HeaderHash header ~ HeaderHash block, MonadMonotonicTime m) - => FetchDecisionPolicy header + => Tracer m (TraceDecisionEvent peer header) + -> FetchDecisionPolicy header -> FetchMode -> AnchoredFragment header -> (Point block -> Bool) @@ -55,6 +58,7 @@ fetchDecisions -> m [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisions + _tracer fetchDecisionPolicy FetchModeDeadline currentChain @@ -73,6 +77,7 @@ fetchDecisions candidatesAndPeers fetchDecisions + tracer fetchDecisionPolicy FetchModeBulkSync currentChain @@ -83,6 +88,7 @@ fetchDecisions candidatesAndPeers = fetchDecisionsBulkSyncM + tracer fetchDecisionPolicy currentChain fetchedBlocks diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index c9b9e987c1b..60b1d65bf5a 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -132,6 +132,7 @@ import Control.Monad (filterM, when) import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime), addTime) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) +import Control.Tracer (Tracer, traceWith) import Data.Bifunctor (first, Bifunctor (..)) import qualified Data.List as List import Data.List.NonEmpty (nonEmpty) @@ -151,6 +152,7 @@ import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) import Ouroboros.Network.BlockFetch.Decision.Deadline +import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..)) -- | A trivial foldable data structure with a 'Semigroup' instance that -- concatenates in @O(1)@. Only meant for short-term use, followed by one fold. @@ -178,7 +180,8 @@ fetchDecisionsBulkSyncM (Ord peer, HasHeader header, HeaderHash header ~ HeaderHash block, MonadMonotonicTime m) - => FetchDecisionPolicy header + => Tracer m (TraceDecisionEvent peer header) + -> FetchDecisionPolicy header -> AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo @@ -190,6 +193,7 @@ fetchDecisionsBulkSyncM -> [(AnchoredFragment header, PeerInfo header peer extra)] -> m [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisionsBulkSyncM + tracer fetchDecisionPolicy@FetchDecisionPolicy {bulkSyncGracePeriod} currentChain fetchedBlocks @@ -258,6 +262,7 @@ fetchDecisionsBulkSyncM Just (_,_,_,badPeer,_) -> if lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart then do + traceWith tracer $ PeerStarvedUs badPeer demoteCSJDynamoAndIgnoreInflightBlocks badPeer let peersOrder' = PeersOrder diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Trace.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Trace.hs index 423239b9339..e32316def20 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Trace.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Trace.hs @@ -7,4 +7,5 @@ import Ouroboros.Network.BlockFetch.Decision.Deadline (FetchDecision) data TraceDecisionEvent peer header = PeersFetch [TraceLabelPeer peer (FetchDecision [Point header])] + | PeerStarvedUs peer deriving (Show) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 85ba1322de5..3a3f3e5803f 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -145,6 +145,7 @@ fetchLogicIteration decisionTracer clientStateTracer -- Make all the fetch decisions decisions <- fetchDecisionsForStateSnapshot + decisionTracer fetchDecisionPolicy stateSnapshot (peersOrder, @@ -196,7 +197,8 @@ fetchDecisionsForStateSnapshot Ord peer, Hashable peer, MonadMonotonicTime m) - => FetchDecisionPolicy header + => Tracer m (TraceDecisionEvent peer header) + -> FetchDecisionPolicy header -> FetchStateSnapshot peer header block m -> ( PeersOrder peer , PeersOrder peer -> m () @@ -207,6 +209,7 @@ fetchDecisionsForStateSnapshot )] fetchDecisionsForStateSnapshot + tracer fetchDecisionPolicy FetchStateSnapshot { fetchStateCurrentChain, @@ -226,6 +229,7 @@ fetchDecisionsForStateSnapshot `Set.isSubsetOf` Map.keysSet fetchStatePeerGSVs) $ fetchDecisions + tracer fetchDecisionPolicy fetchStateFetchMode fetchStateCurrentChain From 7a84d64478974362e2858c4601acbb7703a01123 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Tue, 16 Jul 2024 17:44:07 +0200 Subject: [PATCH 094/136] Extract Genesis-specific config params in their own type --- ouroboros-network/demo/chain-sync.hs | 4 +++- .../Ouroboros/Network/BlockFetch/Examples.hs | 8 ++++++-- .../Test/Ouroboros/Network/Diffusion/Node.hs | 4 +++- .../src/Ouroboros/Network/BlockFetch.hs | 17 +++++++++++++---- .../Network/Diffusion/Configuration.hs | 17 ++++++++++------- 5 files changed, 35 insertions(+), 15 deletions(-) diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 0ac3ec4da8b..49bd4719557 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -515,7 +515,9 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, bfcSalt = 0, - bfcBulkSyncGracePeriod = 10 -- seconds + bfcGenesisBFConfig = GenesisBlockFetchConfiguration + { gbfcBulkSyncGracePeriod = 10 -- seconds + } }) >> return () diff --git a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs index 9518bb77d27..dfff344a20e 100644 --- a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -139,7 +139,9 @@ blockFetchExample0 decisionTracer clientStateTracer clientMsgTracer bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, bfcSalt = 0, - bfcBulkSyncGracePeriod = 10 -- seconds + bfcGenesisBFConfig = GenesisBlockFetchConfiguration + { gbfcBulkSyncGracePeriod = 10 -- seconds + } }) >> return () @@ -247,7 +249,9 @@ blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, bfcSalt = 0, - bfcBulkSyncGracePeriod = 10 -- seconds + bfcGenesisBFConfig = GenesisBlockFetchConfiguration + { gbfcBulkSyncGracePeriod = 10 -- seconds + } }) >> return () diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs index 0f23d99daff..6b75eb1599c 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -295,7 +295,9 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = bfcMaxRequestsInflight = 10, bfcDecisionLoopInterval = 0.01, bfcSalt = 0, - bfcBulkSyncGracePeriod = 10 -- seconds + bfcGenesisBFConfig = GenesisBlockFetchConfiguration + { gbfcBulkSyncGracePeriod = 10 -- seconds + } }) blockFetchPolicy :: NodeKernel BlockHeader Block s m diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index 25a49933890..b6718dab6d8 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -84,6 +84,7 @@ module Ouroboros.Network.BlockFetch ( blockFetchLogic , BlockFetchConfiguration (..) , BlockFetchConsensusInterface (..) + , GenesisBlockFetchConfiguration (..) -- ** Tracer types , FetchDecision , TraceFetchClientState (..) @@ -141,12 +142,20 @@ data BlockFetchConfiguration = -- | Salt used when comparing peers bfcSalt :: !Int, - -- | Grace period when starting to talk to a peer in bulk sync mode - -- during which it is fine if the chain selection gets starved. - bfcBulkSyncGracePeriod :: !DiffTime + -- | Genesis-specific parameters + bfcGenesisBFConfig :: !GenesisBlockFetchConfiguration } deriving (Show) +-- | BlockFetch configuration parameters specific to Genesis. +data GenesisBlockFetchConfiguration = + GenesisBlockFetchConfiguration + { -- | Grace period when starting to talk to a peer in bulk sync mode + -- during which it is fine if the chain selection gets starved. + gbfcBulkSyncGracePeriod :: !DiffTime + } + deriving (Show) + -- | Execute the block fetch logic. It monitors the current chain and candidate -- chains. It decided which block bodies to fetch and manages the process of -- fetching them, including making alternative decisions based on timeouts and @@ -200,7 +209,7 @@ blockFetchLogic decisionTracer clientStateTracer maxConcurrencyDeadline = bfcMaxConcurrencyDeadline, decisionLoopInterval = bfcDecisionLoopInterval, peerSalt = bfcSalt, - bulkSyncGracePeriod = bfcBulkSyncGracePeriod, + bulkSyncGracePeriod = gbfcBulkSyncGracePeriod bfcGenesisBFConfig, plausibleCandidateChain, compareCandidateChains, diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index e3da98cc8a2..d141bf6e204 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -31,7 +31,7 @@ module Ouroboros.Network.Diffusion.Configuration import System.Random (randomRIO) -import Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..)) +import Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..), GenesisBlockFetchConfiguration (..)) import Ouroboros.Network.ConnectionManager.Core (defaultProtocolIdleTimeout, defaultResetTimeout, defaultTimeWaitTimeout) import Ouroboros.Network.Diffusion (P2P (..)) @@ -90,12 +90,15 @@ defaultPeerSharing = PeerSharingDisabled -- | Configuration for FetchDecisionPolicy. defaultBlockFetchConfiguration :: Int -> BlockFetchConfiguration defaultBlockFetchConfiguration bfcSalt = - BlockFetchConfiguration { - bfcMaxConcurrencyDeadline = 1, - bfcMaxRequestsInflight = fromIntegral $ blockFetchPipeliningMax defaultMiniProtocolParameters, - bfcDecisionLoopInterval = 0.01, -- 10ms - bfcBulkSyncGracePeriod = 10, -- seconds - bfcSalt } + BlockFetchConfiguration + { bfcMaxConcurrencyDeadline = 1 + , bfcMaxRequestsInflight = fromIntegral $ blockFetchPipeliningMax defaultMiniProtocolParameters + , bfcDecisionLoopInterval = 0.01 -- 10ms + , bfcGenesisBFConfig = GenesisBlockFetchConfiguration + { gbfcBulkSyncGracePeriod = 10 -- seconds + } + , bfcSalt + } defaultChainSyncTimeout :: IO ChainSyncTimeout defaultChainSyncTimeout = do From bef3798ee166d5d417e23cdff069e3133b1dbb27 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 17 Jul 2024 10:07:43 +0200 Subject: [PATCH 095/136] Update documentation to the latest design - Incorporate Nick's remark that we should just keep the current peer. - Incorporate Facundo's remark that ignored in-flight blocks are not necessary anymore. --- .../Network/BlockFetch/Decision/BulkSync.hs | 82 +++++++++++-------- 1 file changed, 48 insertions(+), 34 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 60b1d65bf5a..ba2ecfb97fd 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -19,10 +19,6 @@ -- - Let @inflight :: peer -> Set blk@ be the outstanding blocks, those that -- have been requested and are expected to arrive but have not yet. -- --- - Let @inflightIgnored :: Set blk@ be the outstanding blocks that have been --- ignored. We have that @inflightIgnored@ is included in the union for all --- peer @p@ of @inflight(p)@. We name @inflightNonIgnored@ the difference. --- -- - Let @peersOrder@ be an order of preference among the peers. This order is -- not set in stone and will evolve as we go. -- @@ -39,52 +35,70 @@ -- -- One iteration of this decision logic: -- --- - If @inflight@ is non-empty and the block validation component has idled at --- any point after @currentStart@ plus @gracePeriod@, then the peer --- @currentPeer@ has failed to promptly serve @inflight(currentPeer)@, and: +-- 0. If @inflight(currentPeer)@ is non-empty and the block validation component +-- has idled at any point after @currentStart@ plus @gracePeriod@, then the +-- peer @currentPeer@ has failed to promptly serve @inflight(currentPeer)@, +-- and: -- -- - If @currentPeer@ is the ChainSync Jumping dynamo, then it must -- immediately be replaced as the dynamo. -- --- - Assume @currentPeer@ will never finish replying to that fetch request and --- add all of @inflight(currentPeer)@ to @inflightIgnored@. REVIEW: Nick's --- description says to add all of @inflight@ (for all the peers) to --- @inflightIgnored@, probably because it assumes/enforces that @inflight == --- inflight(currentPeer)@, that is only the current peer is allowed to have --- in-flight blocks. --- -- - Stop considering the peer “current” and make them the worst according to -- the @peersOrder@. -- --- - Let @theCandidate :: AnchoredFragment (Header blk)@ be the best candidate --- header chain among the ChainSync clients (eg. best raw tiebreaker among the --- longest). +-- 1. Select @theCandidate :: AnchoredFragment (Header blk)@. This is the best +-- candidate header chain among the ChainSync clients (eg. best raw +-- tiebreaker among the longest). -- --- - Let @grossRequest@ be the oldest blocks on @theCandidate@ that have not --- already been downloaded, are not in @inflightNonIgnored@, and total less --- than 20 mebibytes. +-- 2. Select @thePeer :: peer@. If @inflight(currentPeer)@ is not empty, then +-- this is @currentPeer@. Otherwise: -- --- - If @grossRequest@ is empty, then terminate this iteration. Otherwise, pick --- the best peer (according to @peersOrder@) offering all of the blocks in --- @grossRequest@. We will call it @thePeer@. Because @currentPeer@, if it --- exists, is the best according to @peersOrder@, then it will be our --- preferred peer, as long as it can provide the @grossRequest@s. +-- - Let @grossRequest@ be the oldest blocks on @theCandidate@ that have not +-- already been downloaded and total less than 20 mebibytes. -- --- - If the byte size of @inflight(thePeer)@ is below the low-water mark, then --- terminate this iteration. Otherwise, decide and send the actual next batch --- request, as influenced by exactly which blocks are actually already --- currently in-flight with the chosen peer. +-- - If @grossRequest@ is empty, then terminate this iteration. Otherwise, +-- pick the best peer (according to @peersOrder@) offering all of the +-- blocks in @grossRequest@. -- --- - Update @currentPeer@ and @currentStart@, if needed. Namely: +-- 3. Craft that actual request to @thePeer@ asking blocks of @theCandidate@: -- --- - If @thePeer /= currentPeer@, then make @thePeer@ the current peer and the --- best according to @peersOrder@, and reset @currentStart@ to now. +-- - If the byte size of @inflight(thePeer)@ is below the low-water mark, +-- then terminate this iteration. -- --- - If @thePeer == currentPeer@, but @inflight(thePeer)@ is empty, then reset --- @currentStart@ to now. +-- - Decide and send the actual next batch request, as influenced by exactly +-- which blocks are actually already currently in-flight with @thePeer@. +-- +-- 4. If we went through the election of a new peer, replace @currentPeer@ and +-- reset @currentStart@. REVIEW: Maybe this should just be done directly in +-- step 2. -- -- Terminate this iteration. -- +-- About ignored in-flight requests +-- -------------------------------- +-- +-- One can note that in-flight requests are ignored when finding a new peer, but +-- considered when crafting the actual request to a chosen peer. This is by +-- design. The goal of this algorithm is to keep talking to the same peer unless +-- it proves to be too weak; in that case, @inflight(p)@ will be empty for all +-- @p /= currentPeer@. +-- +-- If a peer proves too slow, then we give up on it (see point 0. above), even +-- if it has requests in-flight. In subsequent selections of peers (point 2.), +-- the blocks in these requests will not be removed from @theCandidate@ as, as +-- far as we know, these requests might never return. +-- +-- When crafting the actual request, we do need to consider the in-flight +-- requests of the peer, to avoid clogging our network. If some of these +-- in-flight requests date from when the peer was previously “current”, this +-- means that we cycled through all the peers that provided @theCandidate@ and +-- they all failed to serve our blocks promptly. +-- +-- This is a degenerate case of the algorithm that might happen but only be +-- transient. Soon enough, @theCandidate@ should be honest (if the consensus +-- layer does its job correctly), and there should exist an honest peer ready to +-- serve @theCandidate@ promptly. +-- -- Interactions with ChainSync Jumping (CSJ) -- ----------------------------------------- -- From a508f0629754962f7e7a47f5ce633723a1c99812 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Wed, 17 Jul 2024 17:34:30 +0200 Subject: [PATCH 096/136] Make in-flight blocks a set again --- .../Test/Ouroboros/Network/BlockFetch.hs | 4 +- .../Ouroboros/Network/BlockFetch/Client.hs | 4 +- .../Network/BlockFetch/ClientRegistry.hs | 2 +- .../Network/BlockFetch/ClientState.hs | 59 ++++++------------ .../Network/BlockFetch/Decision/BulkSync.hs | 61 ++++++++++--------- .../Network/BlockFetch/Decision/Deadline.hs | 3 +- .../src/Ouroboros/Network/BlockFetch/State.hs | 17 +----- 7 files changed, 60 insertions(+), 90 deletions(-) diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs index 353b2adaaba..d0e9f8a52af 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs @@ -373,7 +373,7 @@ tracePropertyClientStateSanity es = saneStateValues PeerFetchInFlight {..} status = -- Here we know the fixed dummy block size so we know exactly what -- the bytes in flight should be. - Map.size peerFetchBlocksInFlight * 2000 + Set.size peerFetchBlocksInFlight * 2000 == fromIntegral peerFetchBytesInFlight && case status of @@ -382,7 +382,7 @@ tracePropertyClientStateSanity es = _ -> False -- not used in this test && if peerFetchReqsInFlight == 0 - then Map.null peerFetchBlocksInFlight + then Set.null peerFetchBlocksInFlight else True diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs index 3f6ccd847fb..38b4d662a0e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs @@ -26,7 +26,7 @@ import Control.Monad (unless) import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI -import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Control.Tracer (traceWith) @@ -117,7 +117,7 @@ blockFetchClient _version controlMessageSTM reportFetched assert ( peerFetchReqsInFlight == 0 && peerFetchBytesInFlight == 0 && - Map.null peerFetchBlocksInFlight ) + Set.null peerFetchBlocksInFlight ) $ pure (senderAwait Zero) senderAwait :: forall n. diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientRegistry.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientRegistry.hs index 65098f3ce66..bdbdb01da23 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientRegistry.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientRegistry.hs @@ -144,7 +144,7 @@ bracketFetchClient (FetchClientRegistry ctxVar Just (cTid, doneVar, startVar) -> do putTMVar startVar () writeTVar (fetchClientStatusVar $ fetchClientCtxStateVars ctx) - (PeerFetchStatusReady Map.empty IsIdle) + (PeerFetchStatusReady Set.empty IsIdle) return (ctx, (cTid, doneVar)) ) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index 977f8df9ff2..d71fab60694 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -18,7 +18,6 @@ module Ouroboros.Network.BlockFetch.ClientState , PeerFetchStatus (..) , IsIdle (..) , PeerFetchInFlight (..) - , PeerFetchBlockInFlight (..) , initialPeerFetchInFlight , FetchRequest (..) , addNewFetchRequest @@ -33,7 +32,6 @@ module Ouroboros.Network.BlockFetch.ClientState -- * Ancillary , FromConsensus (..) , WhetherReceivingTentativeBlocks (..) - , defaultPeerFetchBlockInFlight , PeersOrder(..) , mcons , msnoc @@ -42,8 +40,7 @@ module Ouroboros.Network.BlockFetch.ClientState import Data.List (foldl') import Data.Maybe (mapMaybe) import Data.Semigroup (Last (..)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Set (Set) import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) @@ -64,6 +61,7 @@ import Ouroboros.Network.ControlMessage (ControlMessageSTM, timeoutWithControlMessage) import Ouroboros.Network.Point (withOriginToMaybe) import Ouroboros.Network.Protocol.BlockFetch.Type (ChainRange (..)) +import qualified Data.Set as Set -- | The context that is passed into the block fetch protocol client when it -- is started. @@ -182,7 +180,7 @@ data PeerFetchStatus header = -- considered ready to accept new requests. -- -- The 'Set' is the blocks in flight. - | PeerFetchStatusReady (Map (Point header) PeerFetchBlockInFlight) IsIdle + | PeerFetchStatusReady (Set (Point header)) IsIdle deriving (Eq, Show) -- | Whether this mini protocol instance is in the @Idle@ State @@ -224,7 +222,7 @@ data PeerFetchInFlight header = PeerFetchInFlight { -- fetch from which peers we take into account what blocks are already -- in-flight with peers. -- - peerFetchBlocksInFlight :: Map (Point header) PeerFetchBlockInFlight, + peerFetchBlocksInFlight :: Set (Point header), -- | The maximum slot of a block that /has ever been/ in flight for -- this peer. @@ -236,24 +234,12 @@ data PeerFetchInFlight header = PeerFetchInFlight { } deriving (Eq, Show) --- | Information associated to a block in flight. -data PeerFetchBlockInFlight = PeerFetchBlockInFlight - { -- | The block fetch decision logic might decide to ignore a block that is - -- in flight. It will only be ignored when taking decisions, by it can of - -- course not be ignored when computing the actual request. - peerFetchBlocksInFlightIgnoredByLogic :: !Bool - } - deriving (Eq, Show) - -defaultPeerFetchBlockInFlight :: PeerFetchBlockInFlight -defaultPeerFetchBlockInFlight = PeerFetchBlockInFlight False - initialPeerFetchInFlight :: PeerFetchInFlight header initialPeerFetchInFlight = PeerFetchInFlight { peerFetchReqsInFlight = 0, peerFetchBytesInFlight = 0, - peerFetchBlocksInFlight = Map.empty, + peerFetchBlocksInFlight = Set.empty, peerFetchMaxSlotNo = NoMaxSlotNo } @@ -275,7 +261,7 @@ addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight = -- This assertion checks the pre-condition 'addNewFetchRequest' that all -- requested blocks are new. This is true irrespective of fetch-request -- command merging. - assert (and [ blockPoint header `Map.notMember` peerFetchBlocksInFlight inflight + assert (and [ blockPoint header `Set.notMember` peerFetchBlocksInFlight inflight | fragment <- fetchRequestFragments addedReq , header <- AF.toOldestFirst fragment ]) $ @@ -297,15 +283,11 @@ addHeadersInFlight blockFetchSize oldReq addedReq mergedReq inflight = | fragment <- fetchRequestFragments addedReq , header <- AF.toOldestFirst fragment ], - peerFetchBlocksInFlight = - Map.unionWith - (\_ _ -> error "addHeadersInFlight: precondition violated") - (peerFetchBlocksInFlight inflight) - ( Map.fromList - [ (blockPoint header, defaultPeerFetchBlockInFlight) - | fragment <- fetchRequestFragments addedReq - , header <- AF.toOldestFirst fragment ] - ), + peerFetchBlocksInFlight = peerFetchBlocksInFlight inflight + `Set.union` Set.fromList + [ blockPoint header + | fragment <- fetchRequestFragments addedReq + , header <- AF.toOldestFirst fragment ], peerFetchMaxSlotNo = peerFetchMaxSlotNo inflight `max` fetchRequestMaxSlotNo addedReq @@ -321,13 +303,13 @@ deleteHeaderInFlight :: HasHeader header -> PeerFetchInFlight header deleteHeaderInFlight blockFetchSize header inflight = assert (peerFetchBytesInFlight inflight >= blockFetchSize header) $ - assert (blockPoint header `Map.member` peerFetchBlocksInFlight inflight) $ + assert (blockPoint header `Set.member` peerFetchBlocksInFlight inflight) $ inflight { peerFetchBytesInFlight = peerFetchBytesInFlight inflight - blockFetchSize header, peerFetchBlocksInFlight = blockPoint header - `Map.delete` peerFetchBlocksInFlight inflight + `Set.delete` peerFetchBlocksInFlight inflight } deleteHeadersInFlight :: HasHeader header @@ -613,7 +595,7 @@ completeFetchBatch tracer inflightlimits range let !inflight' = assert (if peerFetchReqsInFlight inflight == 1 then peerFetchBytesInFlight inflight == 0 - && Map.null (peerFetchBlocksInFlight inflight) + && Set.null (peerFetchBlocksInFlight inflight) else True) inflight { peerFetchReqsInFlight = peerFetchReqsInFlight inflight - 1 @@ -621,9 +603,9 @@ completeFetchBatch tracer inflightlimits range writeTVar fetchClientInFlightVar inflight' currentStatus' <- readTVar fetchClientStatusVar >>= \case PeerFetchStatusReady bs IsNotIdle - | Map.null bs + | Set.null bs && 0 == peerFetchReqsInFlight inflight' - -> let status = PeerFetchStatusReady Map.empty IsIdle + -> let status = PeerFetchStatusReady Set.empty IsIdle in status <$ writeTVar fetchClientStatusVar status currentStatus -> pure currentStatus @@ -808,14 +790,13 @@ tryReadTMergeVar :: MonadSTM m tryReadTMergeVar (TMergeVar v) = tryReadTMVar v -- | The order of peers for bulk sync fetch decisions. --- --- FIXME: peersOrderStart would make much more sense as part of the in-flight --- stuff. data PeersOrder peer = PeersOrder - { peersOrderAll :: [peer] + { peersOrderCurrent :: Maybe peer + -- ^ The current peer we are fetching from, if there is one. + , peersOrderAll :: [peer] -- ^ All the peers, from most preferred to least preferred. , peersOrderStart :: Time - -- ^ The time at which we started talking to that peer. + -- ^ The time at which we started talking to the current peer. } mcons :: Maybe a -> [a] -> [a] diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index ba2ecfb97fd..7239d381d85 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -141,7 +141,6 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM ) where -import Control.Exception (assert) import Control.Monad (filterM, when) import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime), addTime) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) @@ -151,7 +150,6 @@ import Data.Bifunctor (first, Bifunctor (..)) import qualified Data.List as List import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe, maybeToList, isNothing) import Data.Ord (Down(Down)) @@ -160,7 +158,7 @@ import Cardano.Prelude (partitionEithers, (&)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), PeerFetchBlockInFlight (..), PeerFetchInFlight (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) @@ -218,7 +216,7 @@ fetchDecisionsBulkSyncM demoteCSJDynamoAndIgnoreInflightBlocks ) candidatesAndPeers = do - peersOrder <- + peersOrder@PeersOrder{peersOrderCurrent} <- peersOrder0 -- Align the peers order with the actual peers; this consists in removing -- all peers from the peers order that are not in the actual peers list and @@ -232,6 +230,10 @@ fetchDecisionsBulkSyncM -- and ignore its in-flight blocks for the future. & checkLastChainSelStarvation + let peersOrderCurrentInfo = + peersOrderCurrent >>= \peersOrderCurrent_ -> + List.find (eqPeerInfo' peersOrderCurrent_) $ map snd candidatesAndPeers + -- Compute the actual block fetch decision. This contains only declines and -- at most one request. 'theDecision' is therefore a 'Maybe'. let (theDecision, declines) = @@ -241,14 +243,17 @@ fetchDecisionsBulkSyncM fetchedBlocks fetchedMaxSlotNo peersOrder - mCurrentPeer + peersOrderCurrentInfo candidatesAndPeers -- If there were no blocks in flight, then this will be the first request, -- so we take a new current time. - when (isNothing mCurrentPeer) $ do - peersOrderStart <- getMonotonicTime - writePeersOrder $ peersOrder {peersOrderStart} + when (isNothing peersOrderCurrent) $ + case theDecision of + Just (_, (_,_,_,thePeer,_)) -> do + peersOrderStart <- getMonotonicTime + writePeersOrder $ peersOrder {peersOrderCurrent = Just thePeer, peersOrderStart} + _ -> pure () pure $ map (first Right) (maybeToList theDecision) @@ -257,30 +262,36 @@ fetchDecisionsBulkSyncM alignPeersOrderWithActualPeers :: [peer] -> PeersOrder peer -> PeersOrder peer alignPeersOrderWithActualPeers actualPeers - PeersOrder {peersOrderStart, peersOrderAll} = - let peersOrderAll' = + PeersOrder {peersOrderStart, peersOrderCurrent, peersOrderAll} = + let peersOrderCurrent' = case peersOrderCurrent of + Just peersOrderCurrent_ | peersOrderCurrent_`elem` actualPeers -> peersOrderCurrent + _ -> Nothing + peersOrderAll' = filter (`elem` actualPeers) peersOrderAll ++ filter (\peer -> peer `notElem` peersOrderAll) actualPeers in PeersOrder - { peersOrderAll = peersOrderAll', + { peersOrderCurrent = peersOrderCurrent', + peersOrderAll = peersOrderAll', peersOrderStart } checkLastChainSelStarvation :: PeersOrder peer -> m (PeersOrder peer) checkLastChainSelStarvation - peersOrder@PeersOrder {peersOrderStart, peersOrderAll} = do + peersOrder@PeersOrder {peersOrderStart, peersOrderCurrent, peersOrderAll} = do lastStarvationTime <- case chainSelStarvation of ChainSelStarvationEndedAt time -> pure time ChainSelStarvationOngoing -> getMonotonicTime - case mCurrentPeer of - Just (_,_,_,badPeer,_) -> + case peersOrderCurrent of + Just peersOrderCurrent_ -> if lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart then do - traceWith tracer $ PeerStarvedUs badPeer - demoteCSJDynamoAndIgnoreInflightBlocks badPeer + traceWith tracer $ PeerStarvedUs peersOrderCurrent_ + demoteCSJDynamoAndIgnoreInflightBlocks peersOrderCurrent_ let peersOrder' = PeersOrder - { peersOrderAll = filter (/= badPeer) peersOrderAll ++ [badPeer], + { + peersOrderCurrent = Nothing, + peersOrderAll = filter (/= peersOrderCurrent_) peersOrderAll ++ [peersOrderCurrent_], peersOrderStart } writePeersOrder peersOrder' @@ -288,19 +299,6 @@ fetchDecisionsBulkSyncM else pure peersOrder Nothing -> pure peersOrder - mCurrentPeer = - let peersWithBlocksInFlightNonIgnored = - filter - ( \(_, inflight, _, _, _) -> - not $ Map.null $ Map.filter (\(PeerFetchBlockInFlight b) -> not b) $ peerFetchBlocksInFlight inflight - ) - (map snd candidatesAndPeers) - in case peersWithBlocksInFlightNonIgnored of - peerInfo : otherPeersWithBlocksInFlightNonIgnored -> - assert (List.null otherPeersWithBlocksInFlightNonIgnored) $ - Just peerInfo - _ -> Nothing - -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. fetchDecisionsBulkSync :: @@ -603,3 +601,6 @@ extractFirstElem p (x : xs) eqPeerInfo :: Eq peer => PeerInfo header peer extra -> PeerInfo header peer extra -> Bool eqPeerInfo (_,_,_,p1,_) (_,_,_,p2,_) = p1 == p2 + +eqPeerInfo' :: Eq peer => peer -> PeerInfo header peer extra -> Bool +eqPeerInfo' p1 (_,_,_,p2,_) = p1 == p2 diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index 502dc72fc76..a46b2575a00 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -14,7 +14,6 @@ import Control.Monad.Class.MonadTime.SI (DiffTime) import Data.Function (on) import Data.Hashable import Data.List (foldl', groupBy, sortBy, transpose) -import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import Data.Set (Set) import Data.Set qualified as Set @@ -587,7 +586,7 @@ dropAlreadyInFlightWithPeer inflight (candidate, chainfragments) = else Right (candidate, fragments) where fragments = concatMap (filterWithMaxSlotNo notAlreadyInFlight (peerFetchMaxSlotNo inflight)) chainfragments - notAlreadyInFlight b = blockPoint b `Map.notMember` peerFetchBlocksInFlight inflight + notAlreadyInFlight b = blockPoint b `Set.notMember` peerFetchBlocksInFlight inflight dropAlreadyInFlightWithPeer' :: (HasHeader header) => diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 3a3f3e5803f..3e92ead31dc 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -17,7 +17,6 @@ module Ouroboros.Network.BlockFetch.State , TraceFetchClientState (..) ) where -import Data.Foldable (for_) import Data.Functor.Contravariant (contramap) import Data.Hashable (Hashable) import Data.Map.Strict (Map) @@ -25,7 +24,6 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Void -import Control.Concurrent.Class.MonadSTM.Strict.TVar (modifyTVar) import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked (newTVarIO, StrictTVar, readTVarIO, writeTVar) import Control.Exception (assert) import Control.Monad.Class.MonadSTM @@ -40,7 +38,7 @@ import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchClientStateVars (..), FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..), TraceFetchClientState (..), TraceLabelPeer (..), addNewFetchRequest, - readFetchClientState, PeersOrder (..), PeerFetchBlockInFlight (..)) + readFetchClientState, PeersOrder (..)) import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecisionPolicy (..), FetchDecline (..), FetchMode (..), PeerInfo, fetchDecisions) @@ -71,6 +69,7 @@ fetchLogicIterations decisionTracer clientStateTracer demoteCSJDynamo = do peersOrderVar <- newTVarIO $ PeersOrder { + peersOrderCurrent = Nothing, peersOrderStart = Time 0, peersOrderAll = [] } @@ -150,7 +149,7 @@ fetchLogicIteration decisionTracer clientStateTracer stateSnapshot (peersOrder, atomically . writeTVar peersOrderVar, - demoteCSJDynamoAndIgnoreInflightBlocks) + demoteCSJDynamo) -- If we want to trace timings, we can do it here after forcing: -- _ <- evaluate (force decisions) @@ -178,16 +177,6 @@ fetchLogicIteration decisionTracer clientStateTracer | headers <- headerss , header <- AF.toOldestFirst headers ] - demoteCSJDynamoAndIgnoreInflightBlocks peer = do - demoteCSJDynamo peer - atomically $ do - peerStateVars <- readStatePeerStateVars fetchNonTriggerVariables - for_ peerStateVars $ \peerStateVar -> - modifyTVar (fetchClientInFlightVar peerStateVar) $ \pfif -> - pfif { peerFetchBlocksInFlight = - fmap (const (PeerFetchBlockInFlight True)) (peerFetchBlocksInFlight pfif) - } - -- | Do a bit of rearranging of data before calling 'fetchDecisions' to do the -- real work. -- From c4511914c0f38f34f4761c9343ac362798eb59cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicolas=20=E2=80=9CNiols=E2=80=9D=20Jeannerod?= Date: Sat, 20 Jul 2024 00:16:19 +0200 Subject: [PATCH 097/136] Current peer only if inflight blocks --- .../Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 7239d381d85..9ca3ad4002d 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -151,6 +151,7 @@ import qualified Data.List as List import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE import Data.Maybe (mapMaybe, maybeToList, isNothing) +import qualified Data.Set as Set import Data.Ord (Down(Down)) import Cardano.Prelude (partitionEithers, (&)) @@ -158,7 +159,7 @@ import Cardano.Prelude (partitionEithers, (&)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..)) +import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), PeerFetchInFlight (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) @@ -213,7 +214,7 @@ fetchDecisionsBulkSyncM chainSelStarvation ( peersOrder0, writePeersOrder, - demoteCSJDynamoAndIgnoreInflightBlocks + demoteCSJDynamo ) candidatesAndPeers = do peersOrder@PeersOrder{peersOrderCurrent} <- @@ -232,7 +233,9 @@ fetchDecisionsBulkSyncM let peersOrderCurrentInfo = peersOrderCurrent >>= \peersOrderCurrent_ -> - List.find (eqPeerInfo' peersOrderCurrent_) $ map snd candidatesAndPeers + case List.find (eqPeerInfo' peersOrderCurrent_) $ map snd candidatesAndPeers of + Just peerCurrentInfo@(_,inflight,_,_,_) | not (Set.null (peerFetchBlocksInFlight inflight)) -> Just peerCurrentInfo + _ -> Nothing -- Compute the actual block fetch decision. This contains only declines and -- at most one request. 'theDecision' is therefore a 'Maybe'. @@ -286,7 +289,7 @@ fetchDecisionsBulkSyncM if lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart then do traceWith tracer $ PeerStarvedUs peersOrderCurrent_ - demoteCSJDynamoAndIgnoreInflightBlocks peersOrderCurrent_ + demoteCSJDynamo peersOrderCurrent_ let peersOrder' = PeersOrder { From 36266257889727755bc4e14fd3a0a4f836891b20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Fri, 19 Jul 2024 22:40:30 +0000 Subject: [PATCH 098/136] Put only one block in the gross request --- .../Network/BlockFetch/Decision/BulkSync.hs | 25 +++++-------------- 1 file changed, 6 insertions(+), 19 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 9ca3ad4002d..0e169cef04d 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -132,10 +132,8 @@ -- introduction of an objective criterium, which the gross request provides. -- -- If the gross request is included in a peer's candidate, it means that this --- peer can serve at least the first 20 mebibytes of the blocks that we wish to --- fetch. The actual request might be smaller than that, depending on the actual --- in-flight limits, but it might also be bigger because the peer can have more --- blocks than just those. +-- peer can serve at least 1 block that we wish to fetch. The actual request might +-- be bigger than that because the peer can have more blocks. -- module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM @@ -363,7 +361,6 @@ fetchDecisionsBulkSync ) <- MaybeT $ selectThePeer - fetchDecisionPolicy peersOrder mCurrentPeer theFragments @@ -445,7 +442,6 @@ selectThePeer :: ( HasHeader header, Eq peer ) => - FetchDecisionPolicy header -> PeersOrder peer -> -- | The current peer Maybe (PeerInfo header peer extra) -> @@ -459,26 +455,17 @@ selectThePeer :: (PeerInfo header peer extra) (Maybe (ChainSuffix header, PeerInfo header peer extra)) selectThePeer - FetchDecisionPolicy {blockFetchSize} peersOrder mCurrentPeer theFragments candidates = do - -- Create a fetch request for the blocks in question. The request is made to - -- fit in 20 mebibytes but ignores everything else. It is gross in that - -- sense. It will only be used to choose the peer to fetch from, but we will + -- Create a fetch request for the blocks in question. The request has exactly + -- 1 block. It will only be used to choose the peer to fetch from, but we will -- later craft a more refined request for that peer. See [About the gross -- request] in the module documentation. Because @theFragments@ is not -- empty, @grossRequest@ will not be empty. - let (grossRequest :: FetchDecision (FetchRequest header)) = - selectBlocksUpToLimits - blockFetchSize - 0 -- number of request in flight - maxBound -- maximum number of requests in flight - 0 -- bytes in flight - (20 * 1024 * 1024) -- maximum bytes in flight; 20 mebibyte - . snd - <$> theFragments + let firstBlock = FetchRequest . map (AF.takeOldest 1) . take 1 . filter (not . AF.null) + (grossRequest :: FetchDecision (FetchRequest header)) = firstBlock . snd <$> theFragments -- If there is a current peer, then that is the one we choose. Otherwise, we -- can choose any peer, so we choose a “good” one. From ba6d7eab2380dd15aea9e255ea582099c763fb1d Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Mon, 22 Jul 2024 19:48:54 +0200 Subject: [PATCH 099/136] Add missing instances for GenesisBlockFetchCOnfiguration --- ouroboros-network/src/Ouroboros/Network/BlockFetch.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index b6718dab6d8..2d09a54ab41 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -110,6 +111,8 @@ import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer) +import GHC.Generics (Generic) + import Ouroboros.Network.Block import Ouroboros.Network.SizeInBytes (SizeInBytes) @@ -154,7 +157,7 @@ data GenesisBlockFetchConfiguration = -- during which it is fine if the chain selection gets starved. gbfcBulkSyncGracePeriod :: !DiffTime } - deriving (Show) + deriving (Eq, Generic, Show) -- | Execute the block fetch logic. It monitors the current chain and candidate -- chains. It decided which block bodies to fetch and manages the process of From 33bcad59410a887f1e3c0be0c91667c64a420d86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 19:00:07 +0000 Subject: [PATCH 100/136] Drop the empty fragments from the final request --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 0e169cef04d..c7658382f73 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -571,6 +571,7 @@ fetchTheCandidate where trimFragmentsToCandidate candidate fragments = let trimmedFragments = + filter (not . AF.null) $ mapMaybe ( \fragment -> -- 'candidate' is anchored at the immutable tip, so we don't From 6e6eae8ee38f3376c21ae1045370143b6a6a8d76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 19:09:33 +0000 Subject: [PATCH 101/136] Remove extractFirstElement --- .../Network/BlockFetch/Decision/BulkSync.hs | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index c7658382f73..92df0f056b1 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -471,10 +471,11 @@ selectThePeer -- can choose any peer, so we choose a “good” one. case mCurrentPeer of Just thePeerInfo -> do - case extractFirstElem (eqPeerInfo thePeerInfo . snd) candidates of - Nothing -> tell (List [(FetchDeclineChainNotPlausible, thePeerInfo)]) >> return Nothing - Just ((thePeerCandidate, _), otherPeers) -> do - tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers)) + case List.break (eqPeerInfo thePeerInfo . snd) candidates of + (_, []) -> tell (List [(FetchDeclineChainNotPlausible, thePeerInfo)]) >> return Nothing + (otherPeersB, (thePeerCandidate, _) : otherPeersA) -> do + tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeersB)) + tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeersA)) -- REVIEW: This is maybe overkill to check that the whole gross request -- fits in the peer's candidate. Maybe just checking that there is one -- block is sufficient. @@ -584,12 +585,6 @@ fetchTheCandidate then Left FetchDeclineAlreadyFetched else Right trimmedFragments -extractFirstElem :: (a -> Bool) -> [a] -> Maybe (a, [a]) -extractFirstElem _ [] = Nothing -extractFirstElem p (x : xs) - | p x = Just (x, xs) - | otherwise = second (x :) <$> extractFirstElem p xs - eqPeerInfo :: Eq peer => PeerInfo header peer extra -> PeerInfo header peer extra -> Bool eqPeerInfo (_,_,_,p1,_) (_,_,_,p2,_) = p1 == p2 From 6a2e8d8bcfcb3c8a5176a59417e5b258e33ddac1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 19:37:42 +0000 Subject: [PATCH 102/136] Remove eqPeerInfo --- .../Network/BlockFetch/Decision/BulkSync.hs | 24 +++++++++---------- .../Network/BlockFetch/Decision/Deadline.hs | 3 +++ 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 92df0f056b1..edd088ab4dc 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -145,10 +145,11 @@ import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) import Control.Tracer (Tracer, traceWith) import Data.Bifunctor (first, Bifunctor (..)) +import Data.Function (on) import qualified Data.List as List import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (mapMaybe, maybeToList, isNothing) +import Data.Maybe (listToMaybe, mapMaybe, maybeToList, isNothing) import qualified Data.Set as Set import Data.Ord (Down(Down)) @@ -229,11 +230,14 @@ fetchDecisionsBulkSyncM -- and ignore its in-flight blocks for the future. & checkLastChainSelStarvation - let peersOrderCurrentInfo = - peersOrderCurrent >>= \peersOrderCurrent_ -> - case List.find (eqPeerInfo' peersOrderCurrent_) $ map snd candidatesAndPeers of - Just peerCurrentInfo@(_,inflight,_,_,_) | not (Set.null (peerFetchBlocksInFlight inflight)) -> Just peerCurrentInfo - _ -> Nothing + let peersOrderCurrentInfo = do + currentPeer <- peersOrderCurrent + listToMaybe + [ peerCurrentInfo + | (_, peerCurrentInfo@(_, inflight, _, peer, _)) <- candidatesAndPeers + , peer == currentPeer + , not (Set.null (peerFetchBlocksInFlight inflight)) + ] -- Compute the actual block fetch decision. This contains only declines and -- at most one request. 'theDecision' is therefore a 'Maybe'. @@ -471,7 +475,7 @@ selectThePeer -- can choose any peer, so we choose a “good” one. case mCurrentPeer of Just thePeerInfo -> do - case List.break (eqPeerInfo thePeerInfo . snd) candidates of + case List.break (((==) `on` peerInfoPeer) thePeerInfo . snd) candidates of (_, []) -> tell (List [(FetchDeclineChainNotPlausible, thePeerInfo)]) >> return Nothing (otherPeersB, (thePeerCandidate, _) : otherPeersA) -> do tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeersB)) @@ -584,9 +588,3 @@ fetchTheCandidate in if null trimmedFragments then Left FetchDeclineAlreadyFetched else Right trimmedFragments - -eqPeerInfo :: Eq peer => PeerInfo header peer extra -> PeerInfo header peer extra -> Bool -eqPeerInfo (_,_,_,p1,_) (_,_,_,p2,_) = p1 == p2 - -eqPeerInfo' :: Eq peer => peer -> PeerInfo header peer extra -> Bool -eqPeerInfo' p1 (_,_,_,p2,_) = p1 == p2 diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index a46b2575a00..5f244b89694 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -62,6 +62,9 @@ type PeerInfo header peer extra = extra ) +peerInfoPeer :: PeerInfo header peer extra -> peer +peerInfoPeer (_, _, _, p, _) = p + -- | Throughout the decision making process we accumulate reasons to decline -- to fetch any blocks. This type is used to wrap intermediate and final -- results. From 59c250bd2ef961ffd64ed8be6dec51ae8b90a834 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 19:58:19 +0000 Subject: [PATCH 103/136] Rename fetchTheCandidate to makeFetchRequest --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index edd088ab4dc..c98f20e6807 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -373,7 +373,7 @@ fetchDecisionsBulkSync -- Step 4: Fetch the candidate from the selected peer, potentially declining -- it (eg. if the peer is already too busy). MaybeT $ - fetchTheCandidate + makeFetchRequest fetchDecisionPolicy theFragments thePeer @@ -532,7 +532,7 @@ selectThePeer -- | Given a candidate and a peer to sync from, create a request for that -- specific peer. We might take the 'FetchDecision' to decline the request, but -- only for “good” reasons, eg. if the peer is already too busy. -fetchTheCandidate :: +makeFetchRequest :: ( HasHeader header ) => FetchDecisionPolicy header -> @@ -546,7 +546,7 @@ fetchTheCandidate :: WithDeclined (PeerInfo header peer extra) (Maybe (FetchRequest header, PeerInfo header peer extra)) -fetchTheCandidate +makeFetchRequest fetchDecisionPolicy theFragments thePeer@(status, inflight, gsvs, _, _) From 16262773ca40a0bc6fe560c4d8a7b430942b1e28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 19:58:32 +0000 Subject: [PATCH 104/136] Groom comments --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index c98f20e6807..e151634f8ca 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -552,9 +552,7 @@ makeFetchRequest thePeer@(status, inflight, gsvs, _, _) thePeerCandidate = let theDecision = do - -- Keep blocks that are not already in-flight with this peer. NOTE: We - -- already filtered most of them (and more), but now we also filter - -- out then ones that are in-flight AND ignored. + -- Drop blocks that are already in-flight with this peer. fragments <- dropAlreadyInFlightWithPeer inflight =<< theFragments -- Trim the fragments to the peer's candidate, keeping only blocks that @@ -565,11 +563,11 @@ makeFetchRequest fetchRequestDecision fetchDecisionPolicy FetchModeBulkSync - 0 -- bypass all concurrency limits. REVIEW: is this really what we want? + 0 -- bypass all concurrency limits. (calculatePeerFetchInFlightLimits gsvs) inflight status - (Right trimmedFragments) -- FIXME: This is a hack to avoid having to change the signature of 'fetchRequestDecision'. + (Right trimmedFragments) in case theDecision of Left reason -> tell (List [(reason, thePeer)]) >> pure Nothing Right theRequest -> pure $ Just (theRequest, thePeer) From 2a4d66b39e32ac2cbcd541ccf6dd16681fc28434 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 20:00:10 +0000 Subject: [PATCH 105/136] Groom auxiliary definition theFragments --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index e151634f8ca..3585894fc75 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -353,9 +353,8 @@ fetchDecisionsBulkSync -- Step 2: Filter out from the chosen candidate fragment the blocks that -- have already been downloaded. NOTE: if not declined, @theFragments@ is -- guaranteed to be non-empty. - let (theFragments :: FetchDecision (CandidateFragments header)) = - pure theCandidate - >>= dropAlreadyFetched fetchedBlocks fetchedMaxSlotNo + let theFragments :: FetchDecision (CandidateFragments header) + theFragments = dropAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate -- Step 3: Select the peer to sync from. This eliminates peers that cannot -- serve a reasonable batch of the candidate, then chooses the peer to sync From 546adc4dfbb5c0fb51d7202843eee9b38bfae038 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 20:06:17 +0000 Subject: [PATCH 106/136] Groom fetchDecisionsBulkSync --- .../Network/BlockFetch/Decision/BulkSync.hs | 45 ++++++++++--------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 3585894fc75..086394a8903 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -139,7 +139,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM ) where -import Control.Monad (filterM, when) +import Control.Monad (filterM, guard, when) import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime), addTime) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) @@ -153,7 +153,7 @@ import Data.Maybe (listToMaybe, mapMaybe, maybeToList, isNothing) import qualified Data.Set as Set import Data.Ord (Down(Down)) -import Cardano.Prelude (partitionEithers, (&)) +import Cardano.Prelude (partitionEithers) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -217,18 +217,10 @@ fetchDecisionsBulkSyncM ) candidatesAndPeers = do peersOrder@PeersOrder{peersOrderCurrent} <- - peersOrder0 - -- Align the peers order with the actual peers; this consists in removing - -- all peers from the peers order that are not in the actual peers list and - -- adding at the end of the peers order all the actual peers that were not - -- there before. - & alignPeersOrderWithActualPeers - (map (\(_, (_, _, _, peer, _)) -> peer) candidatesAndPeers) - -- If the chain selection has been starved recently, that is after the - -- current peer started (and a grace period), then the current peer is - -- bad. We push it at the end of the queue, demote it from CSJ dynamo, - -- and ignore its in-flight blocks for the future. - & checkLastChainSelStarvation + checkLastChainSelStarvation $ + alignPeersOrderWithActualPeers + (map (peerInfoPeer . snd) candidatesAndPeers) + peersOrder0 let peersOrderCurrentInfo = do currentPeer <- peersOrderCurrent @@ -264,22 +256,31 @@ fetchDecisionsBulkSyncM map (first Right) (maybeToList theDecision) ++ map (first Left) declines where + -- Align the peers order with the actual peers; this consists in removing + -- all peers from the peers order that are not in the actual peers list and + -- adding at the end of the peers order all the actual peers that were not + -- there before. alignPeersOrderWithActualPeers :: [peer] -> PeersOrder peer -> PeersOrder peer alignPeersOrderWithActualPeers actualPeers PeersOrder {peersOrderStart, peersOrderCurrent, peersOrderAll} = - let peersOrderCurrent' = case peersOrderCurrent of - Just peersOrderCurrent_ | peersOrderCurrent_`elem` actualPeers -> peersOrderCurrent - _ -> Nothing + let peersOrderCurrent' = do + peer <- peersOrderCurrent + guard (peer `elem` actualPeers) + pure peer peersOrderAll' = filter (`elem` actualPeers) peersOrderAll - ++ filter (\peer -> peer `notElem` peersOrderAll) actualPeers + ++ filter (`notElem` peersOrderAll) actualPeers in PeersOrder { peersOrderCurrent = peersOrderCurrent', peersOrderAll = peersOrderAll', peersOrderStart } + -- If the chain selection has been starved recently, that is after the + -- current peer started (and a grace period), then the current peer is + -- bad. We push it at the end of the queue, demote it from CSJ dynamo, + -- and ignore its in-flight blocks for the future. checkLastChainSelStarvation :: PeersOrder peer -> m (PeersOrder peer) checkLastChainSelStarvation peersOrder@PeersOrder {peersOrderStart, peersOrderCurrent, peersOrderAll} = do @@ -287,16 +288,16 @@ fetchDecisionsBulkSyncM ChainSelStarvationEndedAt time -> pure time ChainSelStarvationOngoing -> getMonotonicTime case peersOrderCurrent of - Just peersOrderCurrent_ -> + Just peer -> if lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart then do - traceWith tracer $ PeerStarvedUs peersOrderCurrent_ - demoteCSJDynamo peersOrderCurrent_ + traceWith tracer (PeerStarvedUs peer) + demoteCSJDynamo peer let peersOrder' = PeersOrder { peersOrderCurrent = Nothing, - peersOrderAll = filter (/= peersOrderCurrent_) peersOrderAll ++ [peersOrderCurrent_], + peersOrderAll = filter (/= peer) peersOrderAll ++ [peer], peersOrderStart } writePeersOrder peersOrder' From d7c1196b4be5254739583e550d23c4d6ddce94cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 20:40:30 +0000 Subject: [PATCH 107/136] Address review comment to optimize checks when selecting the peer --- .../Network/BlockFetch/Decision/BulkSync.hs | 27 +++++++++---------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 086394a8903..714093bdfa6 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -480,10 +480,7 @@ selectThePeer (otherPeersB, (thePeerCandidate, _) : otherPeersA) -> do tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeersB)) tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeersA)) - -- REVIEW: This is maybe overkill to check that the whole gross request - -- fits in the peer's candidate. Maybe just checking that there is one - -- block is sufficient. - case checkRequestInCandidate thePeerCandidate =<< grossRequest of + case checkRequestHeadInCandidate thePeerCandidate =<< grossRequest of Left reason -> tell (List [(reason, thePeerInfo)]) >> return Nothing Right () -> return $ Just (thePeerCandidate, thePeerInfo) @@ -494,7 +491,7 @@ selectThePeer peers <- filterM ( \(candidate, peer) -> - case checkRequestInCandidate candidate =<< grossRequest of + case checkRequestHeadInCandidate candidate =<< grossRequest of Left reason -> tell (List [(reason, peer)]) >> pure False Right () -> pure True ) @@ -518,16 +515,18 @@ selectThePeer tell $ List $ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers return $ Just (thePeerCandidate, thePeer) where - checkRequestInCandidate :: + checkRequestHeadInCandidate :: ChainSuffix header -> FetchRequest header -> FetchDecision () - checkRequestInCandidate candidate request = - if all isSubfragmentOfCandidate $ fetchRequestFragments request - then pure () - else Left $ FetchDeclineAlreadyFetched -- FIXME: A custom decline reason for this? - where - isSubfragmentOfCandidate fragment = - AF.withinFragmentBounds (AF.anchorPoint fragment) (getChainSuffix candidate) - && AF.withinFragmentBounds (AF.headPoint fragment) (getChainSuffix candidate) + checkRequestHeadInCandidate candidate request = + case fetchRequestFragments request of + fragments@(_:_) + | AF.withinFragmentBounds + (AF.headPoint $ last fragments) + (getChainSuffix candidate) + -> + Right () + _ -> + Left FetchDeclineAlreadyFetched -- | Given a candidate and a peer to sync from, create a request for that -- specific peer. We might take the 'FetchDecision' to decline the request, but From b24e05cd50cac9a089d3027c204d21d4ac69a6a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 21:15:36 +0000 Subject: [PATCH 108/136] Groom comments --- .../Network/BlockFetch/Decision/BulkSync.hs | 73 ++++++++----------- 1 file changed, 29 insertions(+), 44 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 714093bdfa6..ec1fb4b07e1 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -11,9 +11,6 @@ -- specific to the bulk sync mode. This logic reuses parts of the logic for the -- deadline mode, but it is inherently different. -- --- Natural language specification --- ------------------------------ --- -- Definitions: -- -- - Let @inflight :: peer -> Set blk@ be the outstanding blocks, those that @@ -53,14 +50,14 @@ -- 2. Select @thePeer :: peer@. If @inflight(currentPeer)@ is not empty, then -- this is @currentPeer@. Otherwise: -- --- - Let @grossRequest@ be the oldest blocks on @theCandidate@ that have not --- already been downloaded and total less than 20 mebibytes. +-- - Let @grossRequest@ be the oldest block on @theCandidate@ that has not +-- already been downloaded. -- -- - If @grossRequest@ is empty, then terminate this iteration. Otherwise, --- pick the best peer (according to @peersOrder@) offering all of the --- blocks in @grossRequest@. +-- pick the best peer (according to @peersOrder@) offering the +-- block in @grossRequest@. -- --- 3. Craft that actual request to @thePeer@ asking blocks of @theCandidate@: +-- 3. Craft the actual request to @thePeer@ asking blocks of @theCandidate@: -- -- - If the byte size of @inflight(thePeer)@ is below the low-water mark, -- then terminate this iteration. @@ -69,19 +66,16 @@ -- which blocks are actually already currently in-flight with @thePeer@. -- -- 4. If we went through the election of a new peer, replace @currentPeer@ and --- reset @currentStart@. REVIEW: Maybe this should just be done directly in --- step 2. +-- reset @currentStart@. -- -- Terminate this iteration. -- --- About ignored in-flight requests --- -------------------------------- +-- About the influence of in-flight requests +-- ----------------------------------------- -- -- One can note that in-flight requests are ignored when finding a new peer, but -- considered when crafting the actual request to a chosen peer. This is by --- design. The goal of this algorithm is to keep talking to the same peer unless --- it proves to be too weak; in that case, @inflight(p)@ will be empty for all --- @p /= currentPeer@. +-- design. We explain the rationale here. -- -- If a peer proves too slow, then we give up on it (see point 0. above), even -- if it has requests in-flight. In subsequent selections of peers (point 2.), @@ -102,38 +96,30 @@ -- Interactions with ChainSync Jumping (CSJ) -- ----------------------------------------- -- --- This decision logic is not so obviously coupled with CSJ, but it is in some --- subtle ways: --- --- - Because we always require our peers to be able to serve a gross request of --- oldest blocks, peers with longer chains have a better chance to pass this --- criteria and to be selected as current peer. The CSJ dynamo, being always --- ahead of jumpers, has therefore more chances to be selected as the current --- peer. It is still possible for a jumper or a disengaged peer to be --- selected. +-- Because we always require our peers to be able to serve a gross request +-- with an old block, peers with longer chains have a better chance to pass +-- this criteria and to be selected as current peer. The CSJ dynamo, being +-- always ahead of jumpers, has therefore more chances to be selected as the +-- current peer. It is still possible for a jumper or a disengaged peer to be +-- selected. -- --- - If the current peer is the CSJ dynamo, but it is a dishonest peer serving --- headers fast but retaining blocks, it might be able to drastically leash --- us, because its ChainSync client will be stuck behind the forecast horizon --- (and therefore not subject to ChainSync punishments such as the Limit on --- Patience). This is why we need to consider starvation of ChainSel and --- demote peers that let us starve. +-- If the current peer is the CSJ dynamo and it is a dishonest peer that retains +-- blocks, it will get multiple opportunities to do so since it will be selected +-- as the current peer more often. We therefore rotate the dynamo every time it +-- is the current peer and it fails to serve blocks promptly. -- -- About the gross request -- ----------------------- -- --- Morally, we want to select a peer that is able to serve us a batch of oldest --- blocks of @theCandidate@. However, the actual requests depend not only on the --- size of the blocks to fetch, but also on the network performances of the peer --- and what requests it already has in-flight. Looking at what peer can create --- an actual request for @theCandidate@ can be misleading: indeed, our --- @currentPeer@ might not be able to create a request simply because it is --- already busy answering other requests from us. This calls for the --- introduction of an objective criterium, which the gross request provides. +-- We want to select a peer that is able to serve us a batch of oldest blocks +-- of @theCandidate@. However, not every peer will be able to deliver these +-- batches as they might be on different chains. We therefore select a peer only +-- if its candidate fragment contains the block in the gross request. In this +-- way, we ensure that the peer can serve at least one block that we wish to +-- fetch. -- --- If the gross request is included in a peer's candidate, it means that this --- peer can serve at least 1 block that we wish to fetch. The actual request might --- be bigger than that because the peer can have more blocks. +-- If the peer cannot offer any more blocks after that, it will be rotated out +-- soon. -- module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM @@ -419,7 +405,6 @@ selectTheCandidate -- consider longest fragments first. . List.sortOn (Down . headBlockNo . fst) where - -- Very ad-hoc helper. -- Write all of the declined peers, and find the candidate fragment -- if there is any. separateDeclinedAndStillInRace :: @@ -485,8 +470,8 @@ selectThePeer Right () -> return $ Just (thePeerCandidate, thePeerInfo) Nothing -> do - -- For each peer, check whether its candidate contains the gross request in - -- its entirety, otherwise decline it. This will guarantee that the + -- For each peer, check whether its candidate contains the head of the + -- gross request, otherwise decline it. This will guarantee that the -- remaining peers can serve the refined request that we will craft later. peers <- filterM From fe917f3f501f8b528fd2bda4b1fa4fff56827bee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 21:16:10 +0000 Subject: [PATCH 109/136] Use peerInfoPeer instead of pattern matching --- .../Network/BlockFetch/Decision/BulkSync.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index ec1fb4b07e1..da43602e064 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -233,9 +233,12 @@ fetchDecisionsBulkSyncM -- so we take a new current time. when (isNothing peersOrderCurrent) $ case theDecision of - Just (_, (_,_,_,thePeer,_)) -> do + Just (_, peerInfo) -> do peersOrderStart <- getMonotonicTime - writePeersOrder $ peersOrder {peersOrderCurrent = Just thePeer, peersOrderStart} + writePeersOrder $ peersOrder + { peersOrderCurrent = Just (peerInfoPeer peerInfo), + peersOrderStart + } _ -> pure () pure $ @@ -487,9 +490,9 @@ selectThePeer -- we bind the lists in the comprehension is capital. let peersOrdered = [ (candidate, peerInfo) - | peer' <- peersOrderAll peersOrder, - (candidate, peerInfo@(_, _, _, peer, _)) <- peers, - peer == peer' + | peer <- peersOrderAll peersOrder, + (candidate, peerInfo) <- peers, + peerInfoPeer peerInfo == peer ] -- Return the first peer in that order, and decline all the ones that were From 717d49f21d6686f6baaec6eca99bd5db33dcf1fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 21:34:30 +0000 Subject: [PATCH 110/136] Retrieve PeerInfo of the current peer where it is used --- .../Network/BlockFetch/Decision/BulkSync.hs | 41 +++++++------------ 1 file changed, 15 insertions(+), 26 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index da43602e064..1f1ce5c0647 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -125,7 +125,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM ) where -import Control.Monad (filterM, guard, when) +import Control.Monad (filterM, guard) import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime), addTime) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) @@ -135,8 +135,8 @@ import Data.Function (on) import qualified Data.List as List import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (listToMaybe, mapMaybe, maybeToList, isNothing) import qualified Data.Set as Set +import Data.Maybe (mapMaybe, maybeToList) import Data.Ord (Down(Down)) import Cardano.Prelude (partitionEithers) @@ -144,7 +144,8 @@ import Cardano.Prelude (partitionEithers) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeersOrder (..), PeerFetchInFlight (..)) +import Ouroboros.Network.BlockFetch.ClientState + (FetchRequest (..), PeersOrder (..), peerFetchBlocksInFlight) import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode(FetchModeBulkSync)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) @@ -202,21 +203,12 @@ fetchDecisionsBulkSyncM demoteCSJDynamo ) candidatesAndPeers = do - peersOrder@PeersOrder{peersOrderCurrent} <- + peersOrder <- checkLastChainSelStarvation $ alignPeersOrderWithActualPeers (map (peerInfoPeer . snd) candidatesAndPeers) peersOrder0 - let peersOrderCurrentInfo = do - currentPeer <- peersOrderCurrent - listToMaybe - [ peerCurrentInfo - | (_, peerCurrentInfo@(_, inflight, _, peer, _)) <- candidatesAndPeers - , peer == currentPeer - , not (Set.null (peerFetchBlocksInFlight inflight)) - ] - -- Compute the actual block fetch decision. This contains only declines and -- at most one request. 'theDecision' is therefore a 'Maybe'. let (theDecision, declines) = @@ -226,20 +218,20 @@ fetchDecisionsBulkSyncM fetchedBlocks fetchedMaxSlotNo peersOrder - peersOrderCurrentInfo candidatesAndPeers -- If there were no blocks in flight, then this will be the first request, -- so we take a new current time. - when (isNothing peersOrderCurrent) $ - case theDecision of - Just (_, peerInfo) -> do + case theDecision of + Just (_, peerInfo@(_, inflight, _, _, _)) + | Set.null (peerFetchBlocksInFlight inflight) + -> do peersOrderStart <- getMonotonicTime writePeersOrder $ peersOrder { peersOrderCurrent = Just (peerInfoPeer peerInfo), peersOrderStart } - _ -> pure () + _ -> pure () pure $ map (first Right) (maybeToList theDecision) @@ -307,8 +299,6 @@ fetchDecisionsBulkSync :: (Point block -> Bool) -> MaxSlotNo -> PeersOrder peer -> - -- | The current peer, if there is one. - Maybe (PeerInfo header peer extra) -> -- | Association list of the candidate fragments and their associated peers. -- The candidate fragments are anchored in the current chain (not necessarily -- at the tip; and not necessarily forking off immediately). @@ -326,7 +316,6 @@ fetchDecisionsBulkSync fetchedBlocks fetchedMaxSlotNo peersOrder - mCurrentPeer candidatesAndPeers = combineWithDeclined $ do -- Step 1: Select the candidate to sync from. This already eliminates peers -- that have an implausible candidate. It returns the remaining candidates @@ -355,7 +344,6 @@ fetchDecisionsBulkSync MaybeT $ selectThePeer peersOrder - mCurrentPeer theFragments candidatesAndPeers' @@ -435,8 +423,6 @@ selectThePeer :: Eq peer ) => PeersOrder peer -> - -- | The current peer - Maybe (PeerInfo header peer extra) -> -- | The candidate fragment that we have selected to sync from, as suffix of -- the immutable tip. FetchDecision (CandidateFragments header) -> @@ -448,7 +434,6 @@ selectThePeer :: (Maybe (ChainSuffix header, PeerInfo header peer extra)) selectThePeer peersOrder - mCurrentPeer theFragments candidates = do -- Create a fetch request for the blocks in question. The request has exactly @@ -459,9 +444,13 @@ selectThePeer let firstBlock = FetchRequest . map (AF.takeOldest 1) . take 1 . filter (not . AF.null) (grossRequest :: FetchDecision (FetchRequest header)) = firstBlock . snd <$> theFragments + peersOrderCurrentInfo = do + currentPeer <- peersOrderCurrent peersOrder + List.find ((currentPeer ==) . peerInfoPeer) $ map snd candidates + -- If there is a current peer, then that is the one we choose. Otherwise, we -- can choose any peer, so we choose a “good” one. - case mCurrentPeer of + case peersOrderCurrentInfo of Just thePeerInfo -> do case List.break (((==) `on` peerInfoPeer) thePeerInfo . snd) candidates of (_, []) -> tell (List [(FetchDeclineChainNotPlausible, thePeerInfo)]) >> return Nothing From ff1d5ac57d57b7a250151b6048487c00feb70d56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 22 Jul 2024 22:01:23 +0000 Subject: [PATCH 111/136] Groom makeFetchRequest --- .../Network/BlockFetch/Decision/BulkSync.hs | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 1f1ce5c0647..e8350593902 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -136,7 +136,7 @@ import qualified Data.List as List import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set -import Data.Maybe (mapMaybe, maybeToList) +import Data.Maybe (maybeToList) import Data.Ord (Down(Down)) import Cardano.Prelude (partitionEithers) @@ -550,15 +550,11 @@ makeFetchRequest where trimFragmentsToCandidate candidate fragments = let trimmedFragments = - filter (not . AF.null) $ - mapMaybe - ( \fragment -> - -- 'candidate' is anchored at the immutable tip, so we don't - -- need to look for something more complicated than this. - (\(_, prefix, _, _) -> prefix) - <$> AF.intersect (getChainSuffix candidate) fragment - ) - fragments + [ prefix + | fragment <- fragments + , Just (_, prefix, _, _) <- [AF.intersect (getChainSuffix candidate) fragment] + , not (AF.null prefix) + ] in if null trimmedFragments then Left FetchDeclineAlreadyFetched else Right trimmedFragments From 460d18fe135ec73852b4beec49a4928ddbb69300 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Wed, 24 Jul 2024 10:26:08 +0000 Subject: [PATCH 112/136] =?UTF-8?q?Revert=20"Note=20on=20=E2=80=9Cbulk=20s?= =?UTF-8?q?ync=E2=80=9D"?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This reverts commit 9771ed0c94c0b093c00fbcad92d30c55cd88390e. --- .../src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index 60235a43723..4c5e9b28c0e 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -25,8 +25,6 @@ import Ouroboros.Network.Block import Ouroboros.Network.SizeInBytes (SizeInBytes) --- REVIEW: “Bulk Sync” is really not bulk anymore, so maybe we should rename --- this? Just “Sync”? Maybe “Genesis Sync”? data FetchMode = -- | Use this mode when we are catching up on the chain but are stil -- well behind. In this mode the fetch logic will optimise for From 7686f9ce593d669b0dc690e93593e55c91f06f04 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Wed, 24 Jul 2024 17:50:56 +0000 Subject: [PATCH 113/136] Set the default decision loop interval to 40 ms --- .../src/Ouroboros/Network/Diffusion/Configuration.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index d141bf6e204..261966d2f18 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -93,7 +93,7 @@ defaultBlockFetchConfiguration bfcSalt = BlockFetchConfiguration { bfcMaxConcurrencyDeadline = 1 , bfcMaxRequestsInflight = fromIntegral $ blockFetchPipeliningMax defaultMiniProtocolParameters - , bfcDecisionLoopInterval = 0.01 -- 10ms + , bfcDecisionLoopInterval = 0.04 -- 40ms , bfcGenesisBFConfig = GenesisBlockFetchConfiguration { gbfcBulkSyncGracePeriod = 10 -- seconds } From 7284bdaaa4d03bd45e5347b820680eaa8b8e075f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Thu, 25 Jul 2024 10:53:41 +0000 Subject: [PATCH 114/136] Separate the decision loop interval for bulksync and deadline modes --- .../Ouroboros/Network/BlockFetch/Examples.hs | 3 ++- .../src/Ouroboros/Network/BlockFetch.hs | 18 ++++++++++++------ .../Network/BlockFetch/Decision/Deadline.hs | 3 ++- .../src/Ouroboros/Network/BlockFetch/State.hs | 13 ++++++++----- .../Network/Diffusion/Configuration.hs | 3 ++- 5 files changed, 26 insertions(+), 14 deletions(-) diff --git a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs index dfff344a20e..e8f352cabd3 100644 --- a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -137,7 +137,8 @@ blockFetchExample0 decisionTracer clientStateTracer clientMsgTracer (BlockFetchConfiguration { bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, - bfcDecisionLoopInterval = 0.01, + bfcDecisionLoopIntervalBulkSync = 0.04, + bfcDecisionLoopIntervalDeadline = 0.01, bfcSalt = 0, bfcGenesisBFConfig = GenesisBlockFetchConfiguration { gbfcBulkSyncGracePeriod = 10 -- seconds diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index 2d09a54ab41..4b641afa304 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -140,7 +140,12 @@ data BlockFetchConfiguration = bfcMaxRequestsInflight :: !Word, -- | Desired interval between calls to fetchLogicIteration - bfcDecisionLoopInterval :: !DiffTime, + -- in BulkSync mode + bfcDecisionLoopIntervalBulkSync :: !DiffTime, + + -- | Desired interval between calls to fetchLogicIteration + -- in Deadline mode + bfcDecisionLoopIntervalDeadline :: !DiffTime, -- | Salt used when comparing peers bfcSalt :: !Int, @@ -208,11 +213,12 @@ blockFetchLogic decisionTracer clientStateTracer fetchDecisionPolicy :: FetchDecisionPolicy header fetchDecisionPolicy = FetchDecisionPolicy { - maxInFlightReqsPerPeer = bfcMaxRequestsInflight, - maxConcurrencyDeadline = bfcMaxConcurrencyDeadline, - decisionLoopInterval = bfcDecisionLoopInterval, - peerSalt = bfcSalt, - bulkSyncGracePeriod = gbfcBulkSyncGracePeriod bfcGenesisBFConfig, + maxInFlightReqsPerPeer = bfcMaxRequestsInflight, + maxConcurrencyDeadline = bfcMaxConcurrencyDeadline, + decisionLoopIntervalBulkSync = bfcDecisionLoopIntervalBulkSync, + decisionLoopIntervalDeadline = bfcDecisionLoopIntervalDeadline, + peerSalt = bfcSalt, + bulkSyncGracePeriod = gbfcBulkSyncGracePeriod bfcGenesisBFConfig, plausibleCandidateChain, compareCandidateChains, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs index 5f244b89694..1624e8db9e5 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Deadline.hs @@ -38,7 +38,8 @@ data FetchDecisionPolicy header = FetchDecisionPolicy { maxInFlightReqsPerPeer :: Word, -- A protocol constant. maxConcurrencyDeadline :: Word, - decisionLoopInterval :: DiffTime, + decisionLoopIntervalBulkSync :: DiffTime, + decisionLoopIntervalDeadline :: DiffTime, peerSalt :: Int, bulkSyncGracePeriod :: DiffTime, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 3e92ead31dc..6682257f9a3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -81,7 +81,7 @@ fetchLogicIterations decisionTracer clientStateTracer -- + wait for the state to change and make decisions for the new state -- + act on those decisions start <- getMonotonicTime - stateFingerprint' <- fetchLogicIteration + (stateFingerprint', fetchMode) <- fetchLogicIteration decisionTracer clientStateTracer fetchDecisionPolicy fetchTriggerVariables @@ -90,9 +90,12 @@ fetchLogicIterations decisionTracer clientStateTracer (peersOrderVar, demoteCSJDynamo) end <- getMonotonicTime let delta = diffTime end start + loopInterval = case fetchMode of + FetchModeBulkSync -> decisionLoopIntervalBulkSync fetchDecisionPolicy + FetchModeDeadline -> decisionLoopIntervalDeadline fetchDecisionPolicy -- Limit decision is made once every decisionLoopInterval. - threadDelay $ decisionLoopInterval fetchDecisionPolicy - delta - return stateFingerprint' + threadDelay (loopInterval - delta) + pure stateFingerprint' iterateForever :: Monad m => a -> (a -> m a) -> m Void @@ -119,7 +122,7 @@ fetchLogicIteration -> FetchNonTriggerVariables peer header block m -> FetchStateFingerprint peer header block -> (StrictTVar m (PeersOrder peer), peer -> m ()) - -> m (FetchStateFingerprint peer header block) + -> m (FetchStateFingerprint peer header block, FetchMode) fetchLogicIteration decisionTracer clientStateTracer fetchDecisionPolicy fetchTriggerVariables @@ -166,7 +169,7 @@ fetchLogicIteration decisionTracer clientStateTracer let !stateFingerprint'' = updateFetchStateFingerprintPeerStatus statusUpdates stateFingerprint' - return stateFingerprint'' + return (stateFingerprint'', fetchStateFetchMode stateSnapshot) where swizzleReqVar (d,(_,_,g,_,(rq,p))) = (d,g,rq,p) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index 261966d2f18..17d4dd69727 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -93,7 +93,8 @@ defaultBlockFetchConfiguration bfcSalt = BlockFetchConfiguration { bfcMaxConcurrencyDeadline = 1 , bfcMaxRequestsInflight = fromIntegral $ blockFetchPipeliningMax defaultMiniProtocolParameters - , bfcDecisionLoopInterval = 0.04 -- 40ms + , bfcDecisionLoopIntervalBulkSync = 0.04 -- 40ms + , bfcDecisionLoopIntervalDeadline = 0.01 -- 10ms , bfcGenesisBFConfig = GenesisBlockFetchConfiguration { gbfcBulkSyncGracePeriod = 10 -- seconds } From 34c829f85792945cb01fe8e1ca6c9aa7026b3f5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Wed, 24 Jul 2024 20:08:23 +0000 Subject: [PATCH 115/136] Make the output more descriptive on failures of the BlockFetch tests --- .../sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs index d0e9f8a52af..cb8f1c23f1e 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs @@ -240,8 +240,8 @@ tracePropertyBlocksRequestedAndRecievedPerPeer -> [Example1TraceEvent] -> Property tracePropertyBlocksRequestedAndRecievedPerPeer fork1 fork2 es = - requestedFetchPoints === requiredFetchPoints - .&&. receivedFetchPoints === requiredFetchPoints + counterexample "should request the expected blocks" (requestedFetchPoints === requiredFetchPoints) + .&&. counterexample "should receive the expected blocks" (receivedFetchPoints === requiredFetchPoints) where requiredFetchPoints = Map.filter (not . Prelude.null) $ From 439116a9c1defa2c4387d97690bdcef1adae7c34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Wed, 24 Jul 2024 20:08:36 +0000 Subject: [PATCH 116/136] Fix typo in error message --- .../sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs index cb8f1c23f1e..6d38a3f77f5 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs @@ -504,7 +504,7 @@ tracePropertyInFlight = checkTrace Nothing reqsInFlight [] | reqsInFlight > 0 = counterexample - ("traceProeprtyInFlight: reqsInFlight = " ++ show reqsInFlight ++ " ≠ 0") + ("tracePropertyInFlight: reqsInFlight = " ++ show reqsInFlight ++ " ≠ 0") False | otherwise = property True From f4a335d81a01532ddbfcdf5ff3cf8fd976f833fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Thu, 25 Jul 2024 22:19:18 +0000 Subject: [PATCH 117/136] Have failing BlockFetch tests terminate --- .../Ouroboros/Network/BlockFetch/Examples.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs index e8f352cabd3..2c311772168 100644 --- a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -40,6 +40,7 @@ import Ouroboros.Network.Block import Network.TypedProtocol.Core import Network.TypedProtocol.Pipelined +import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.ControlMessage (ControlMessageSTM) import Ouroboros.Network.BlockFetch @@ -214,7 +215,7 @@ blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer driverAsync <- async $ do threadId <- myThreadId labelThread threadId "block-fetch-driver" - driver blockHeap + downloadTimer -- Order of shutdown here is important for this example: must kill off the -- fetch thread before the peer threads. @@ -259,14 +260,11 @@ blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer headerForgeUTCTime (FromConsensus x) = pure $ convertSlotToTimeForTestsAssumingNoHardFork (blockSlot x) - driver :: TestFetchedBlockHeap m Block -> m () - driver blockHeap = do - atomically $ do - heap <- getTestFetchedBlocks blockHeap - check $ - all (\c -> AnchoredFragment.headPoint c `Set.member` heap) - candidateChains - + -- | Terminates after 1 second per block in the candidate chains. + downloadTimer :: m () + downloadTimer = + let totalBlocks = sum $ map AF.length candidateChains + in threadDelay (fromIntegral totalBlocks) -- -- Sample block fetch configurations From ad95337b85930d797b80776a03584dd694a6b4b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Thu, 25 Jul 2024 22:23:56 +0000 Subject: [PATCH 118/136] Fix expectations of test 'static chains without overlap' --- .../Test/Ouroboros/Network/BlockFetch.hs | 25 ++++++++++++------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs index 6d38a3f77f5..f443922ca12 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs @@ -86,8 +86,8 @@ tests = testGroup "BlockFetch" -- | In this test we have two candidates chains that are static throughout the -- run. The two chains share some common prefix (genesis in the degenerate --- case). The test runs the block fetch logic to download all of both chain --- candidates. +-- case). The test runs the block fetch logic to download all blocks of the +-- longest candidate chain (either of them if they are of equal length). -- -- In this variant we set up the common prefix of the two candidates as the -- \"current\" chain. This means the block fetch only has to download the @@ -223,7 +223,8 @@ instance Show Example1TraceEvent where -- blocks in the 'FetchRequest's added by the decision logic and the blocks -- received by the fetch clients; check that the ordered sequence of blocks -- requested and completed by both fetch clients is exactly the sequence --- expected. The expected sequence is exactly the chain suffixes in order. +-- expected. The expected sequence is exactly the longest chain suffix, or +-- either of them if they are of equal length. -- -- This property is stronger than 'tracePropertyBlocksRequestedAndRecievedAllPeers' -- since it works with sequences rather than sets and for each chain @@ -240,15 +241,21 @@ tracePropertyBlocksRequestedAndRecievedPerPeer -> [Example1TraceEvent] -> Property tracePropertyBlocksRequestedAndRecievedPerPeer fork1 fork2 es = - counterexample "should request the expected blocks" (requestedFetchPoints === requiredFetchPoints) - .&&. counterexample "should receive the expected blocks" (receivedFetchPoints === requiredFetchPoints) + counterexample "should request the expected blocks" + (disjoin $ map (requestedFetchPoints ===) requiredFetchPoints) + .&&. counterexample "should receive the expected blocks" + (disjoin $ map (receivedFetchPoints ===) requiredFetchPoints) where requiredFetchPoints = + if AnchoredFragment.length fork1 == AnchoredFragment.length fork2 + then [requiredFetchPointsFor 1 fork1, requiredFetchPointsFor 2 fork2] + else if AnchoredFragment.length fork1 < AnchoredFragment.length fork2 + then [requiredFetchPointsFor 2 fork2] + else [requiredFetchPointsFor 1 fork1] + + requiredFetchPointsFor peer fork = Map.filter (not . Prelude.null) $ - Map.fromList $ - [ (1, chainPoints fork1) - , (2, chainPoints fork2) - ] + Map.fromList [ (peer, chainPoints fork) ] requestedFetchPoints :: Map Int [Point BlockHeader] requestedFetchPoints = From 178872fe3668345b02293221e6272143a7b237ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Fri, 26 Jul 2024 00:11:17 +0000 Subject: [PATCH 119/136] Fix expectations of test 'static chains with overlap' --- .../Test/Ouroboros/Network/BlockFetch.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs index f443922ca12..2f00ef62ac0 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs @@ -281,8 +281,8 @@ tracePropertyBlocksRequestedAndRecievedPerPeer fork1 fork2 es = -- blocks in the 'FetchRequest's added by the decision logic and the blocks -- received by the fetch clients; check that the set of all blocks requested -- across the two peers is the set of blocks we expect, and similarly for the --- set of all blocks received. The expected set of blocks is the union of the --- blocks on the two candidate chains. +-- set of all blocks received. The expected set of blocks is the block of the +-- longest candidate chain, or either of them if they have the same size. -- -- This property is weaker than 'tracePropertyBlocksRequestedAndRecievedPerPeer' -- since it does not involve order or frequency, but it holds for the general @@ -294,11 +294,20 @@ tracePropertyBlocksRequestedAndRecievedAllPeers -> [Example1TraceEvent] -> Property tracePropertyBlocksRequestedAndRecievedAllPeers fork1 fork2 es = - requestedFetchPoints === requiredFetchPoints - .&&. receivedFetchPoints === requiredFetchPoints + counterexample "should request the expected blocks" + (disjoin $ map (requestedFetchPoints ===) requiredFetchPoints) + .&&. counterexample "should receive the expected blocks" + (disjoin $ map (receivedFetchPoints ===) requiredFetchPoints) where requiredFetchPoints = - Set.fromList (chainPoints fork1 ++ chainPoints fork2) + if AnchoredFragment.length fork1 == AnchoredFragment.length fork2 + then [requiredFetchPointsFor fork1, requiredFetchPointsFor fork2] + else if AnchoredFragment.length fork1 < AnchoredFragment.length fork2 + then [requiredFetchPointsFor fork2] + else [requiredFetchPointsFor fork1] + + requiredFetchPointsFor fork = + Set.fromList $ chainPoints fork requestedFetchPoints :: Set (Point BlockHeader) requestedFetchPoints = From 38152f3b5a8d231980e393e439704b52d9a672b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Fri, 26 Jul 2024 13:29:16 +0000 Subject: [PATCH 120/136] Refactoring: resolve declination of the candidate fragments early --- .../Network/BlockFetch/Decision/BulkSync.hs | 37 ++++++++++++------- 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index e8350593902..7e8df5c8dcd 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -288,7 +288,7 @@ fetchDecisionsBulkSyncM -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. -fetchDecisionsBulkSync :: +fetchDecisionsBulkSync :: forall header block peer extra. ( HasHeader header, HeaderHash header ~ HeaderHash block, Eq peer @@ -332,8 +332,8 @@ fetchDecisionsBulkSync -- Step 2: Filter out from the chosen candidate fragment the blocks that -- have already been downloaded. NOTE: if not declined, @theFragments@ is -- guaranteed to be non-empty. - let theFragments :: FetchDecision (CandidateFragments header) - theFragments = dropAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate + theFragments :: CandidateFragments header + <- MaybeT $ dropAlreadyFetchedBlocks candidatesAndPeers' theCandidate -- Step 3: Select the peer to sync from. This eliminates peers that cannot -- serve a reasonable batch of the candidate, then chooses the peer to sync @@ -356,13 +356,24 @@ fetchDecisionsBulkSync thePeer thePeerCandidate where - combineWithDeclined :: - MaybeT (WithDeclined peer) (a, peer) -> - ( Maybe (a, peer), - [(FetchDecline, peer)] + combineWithDeclined :: forall peerInfo a. + MaybeT (WithDeclined peerInfo) (a, peerInfo) -> + ( Maybe (a, peerInfo), + [(FetchDecline, peerInfo)] ) combineWithDeclined = second listConcatToList . runWithDeclined . runMaybeT + dropAlreadyFetchedBlocks :: forall peerInfo. + [(ChainSuffix header, peerInfo)] -> + ChainSuffix header -> + WithDeclined peerInfo (Maybe (CandidateFragments header)) + dropAlreadyFetchedBlocks candidatesAndPeers' theCandidate = + case dropAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate of + Left reason -> do + tell (List [(reason, peerInfo) | (_, peerInfo) <- candidatesAndPeers']) + pure Nothing + Right theFragments -> pure (Just theFragments) + -- | Given a list of candidate fragments and their associated peers, select the -- candidate to sync from. Return this fragment, the list of peers that are -- still in race to serve it, and the list of peers that are already being @@ -425,7 +436,7 @@ selectThePeer :: PeersOrder peer -> -- | The candidate fragment that we have selected to sync from, as suffix of -- the immutable tip. - FetchDecision (CandidateFragments header) -> + CandidateFragments header -> -- | Association list of candidate fragments (as suffixes of the immutable -- tip) and their associated peers. [(ChainSuffix header, PeerInfo header peer extra)] -> @@ -442,7 +453,7 @@ selectThePeer -- request] in the module documentation. Because @theFragments@ is not -- empty, @grossRequest@ will not be empty. let firstBlock = FetchRequest . map (AF.takeOldest 1) . take 1 . filter (not . AF.null) - (grossRequest :: FetchDecision (FetchRequest header)) = firstBlock . snd <$> theFragments + (grossRequest :: FetchRequest header) = firstBlock $ snd theFragments peersOrderCurrentInfo = do currentPeer <- peersOrderCurrent peersOrder @@ -457,7 +468,7 @@ selectThePeer (otherPeersB, (thePeerCandidate, _) : otherPeersA) -> do tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeersB)) tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeersA)) - case checkRequestHeadInCandidate thePeerCandidate =<< grossRequest of + case checkRequestHeadInCandidate thePeerCandidate grossRequest of Left reason -> tell (List [(reason, thePeerInfo)]) >> return Nothing Right () -> return $ Just (thePeerCandidate, thePeerInfo) @@ -468,7 +479,7 @@ selectThePeer peers <- filterM ( \(candidate, peer) -> - case checkRequestHeadInCandidate candidate =<< grossRequest of + case checkRequestHeadInCandidate candidate grossRequest of Left reason -> tell (List [(reason, peer)]) >> pure False Right () -> pure True ) @@ -514,7 +525,7 @@ makeFetchRequest :: FetchDecisionPolicy header -> -- | The candidate fragment that we have selected to sync from, as suffix of -- the immutable tip. - FetchDecision (CandidateFragments header) -> + CandidateFragments header -> -- | The peer that we have selected to sync from. PeerInfo header peer extra -> -- | Its candidate fragment as suffix of the immutable tip. @@ -529,7 +540,7 @@ makeFetchRequest thePeerCandidate = let theDecision = do -- Drop blocks that are already in-flight with this peer. - fragments <- dropAlreadyInFlightWithPeer inflight =<< theFragments + fragments <- dropAlreadyInFlightWithPeer inflight theFragments -- Trim the fragments to the peer's candidate, keeping only blocks that -- they may actually serve. From 43b4491d0ab9a89973b4e5e2b867c1458eaabe7b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Fri, 26 Jul 2024 15:13:01 +0000 Subject: [PATCH 121/136] Sort the peers only once in the decision logic --- .../Network/BlockFetch/Decision/BulkSync.hs | 62 +++++++++---------- 1 file changed, 30 insertions(+), 32 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 7e8df5c8dcd..f4539f70d78 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -133,11 +133,8 @@ import Control.Tracer (Tracer, traceWith) import Data.Bifunctor (first, Bifunctor (..)) import Data.Function (on) import qualified Data.List as List -import Data.List.NonEmpty (nonEmpty) -import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import Data.Maybe (maybeToList) -import Data.Ord (Down(Down)) import Cardano.Prelude (partitionEithers) @@ -203,11 +200,13 @@ fetchDecisionsBulkSyncM demoteCSJDynamo ) candidatesAndPeers = do - peersOrder <- - checkLastChainSelStarvation $ - alignPeersOrderWithActualPeers - (map (peerInfoPeer . snd) candidatesAndPeers) - peersOrder0 + let (peersOrder1, orderedCandidatesAndPeers) = + alignPeersOrderWithActualPeers + (peerInfoPeer . snd) + candidatesAndPeers + peersOrder0 + + peersOrder <- checkLastChainSelStarvation peersOrder1 -- Compute the actual block fetch decision. This contains only declines and -- at most one request. 'theDecision' is therefore a 'Maybe'. @@ -218,7 +217,7 @@ fetchDecisionsBulkSyncM fetchedBlocks fetchedMaxSlotNo peersOrder - candidatesAndPeers + orderedCandidatesAndPeers -- If there were no blocks in flight, then this will be the first request, -- so we take a new current time. @@ -241,22 +240,29 @@ fetchDecisionsBulkSyncM -- all peers from the peers order that are not in the actual peers list and -- adding at the end of the peers order all the actual peers that were not -- there before. - alignPeersOrderWithActualPeers :: [peer] -> PeersOrder peer -> PeersOrder peer + alignPeersOrderWithActualPeers :: forall d. + (d -> peer) -> [d] -> PeersOrder peer -> (PeersOrder peer, [d]) alignPeersOrderWithActualPeers + peerOf actualPeers PeersOrder {peersOrderStart, peersOrderCurrent, peersOrderAll} = let peersOrderCurrent' = do peer <- peersOrderCurrent - guard (peer `elem` actualPeers) + guard (any ((peer ==) . peerOf) actualPeers) pure peer peersOrderAll' = - filter (`elem` actualPeers) peersOrderAll - ++ filter (`notElem` peersOrderAll) actualPeers - in PeersOrder + [ d + | p <- peersOrderAll + , Just d <- [List.find ((p ==) . peerOf) actualPeers] + ] + ++ filter ((`notElem` peersOrderAll) . peerOf) actualPeers + in (PeersOrder { peersOrderCurrent = peersOrderCurrent', - peersOrderAll = peersOrderAll', + peersOrderAll = map peerOf peersOrderAll', peersOrderStart } + , peersOrderAll' + ) -- If the chain selection has been starved recently, that is after the -- current peer started (and a grace period), then the current peer is @@ -403,12 +409,9 @@ selectTheCandidate . selectForkSuffixes currentChain -- Filter to keep chains the consensus layer tells us are plausible. . filterPlausibleCandidates plausibleCandidateChain currentChain - -- Sort the candidates by descending block number of their heads, that is - -- consider longest fragments first. - . List.sortOn (Down . headBlockNo . fst) where - -- Write all of the declined peers, and find the candidate fragment - -- if there is any. + -- Write all of the declined peers, and find the longest candidate + -- fragment if there is any. separateDeclinedAndStillInRace :: [(FetchDecision (ChainSuffix header), peerInfo)] -> WithDeclined peerInfo (Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)])) @@ -416,7 +419,12 @@ selectTheCandidate let (declined, inRace) = partitionEithers [ bimap ((,p)) ((,p)) d | (d, p) <- decisions ] tell (List declined) - return $ ((,inRace) . fst . NE.head) <$> nonEmpty inRace + case inRace of + [] -> pure Nothing + _ : _ -> do + let chainSfx = fst $ + List.maximumBy (compare `on` (headBlockNo . getChainSuffix . fst)) inRace + pure $ Just (chainSfx, inRace) -- | Given _the_ candidate fragment to sync from, and a list of peers (with -- their corresponding candidate fragments), choose which peer to sync _the_ @@ -485,19 +493,9 @@ selectThePeer ) candidates - -- Order the peers according to the peer order that we have been given, then - -- separate between declined peers and the others. NOTE: The order in which - -- we bind the lists in the comprehension is capital. - let peersOrdered = - [ (candidate, peerInfo) - | peer <- peersOrderAll peersOrder, - (candidate, peerInfo) <- peers, - peerInfoPeer peerInfo == peer - ] - -- Return the first peer in that order, and decline all the ones that were -- not already declined. - case peersOrdered of + case peers of [] -> return Nothing (thePeerCandidate, thePeer) : otherPeers -> do tell $ List $ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers From f6a9152b7c1518d869de236b268627b2af4959aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Fri, 26 Jul 2024 15:20:34 +0000 Subject: [PATCH 122/136] Don't update de peers order prematurely --- .../Network/BlockFetch/Decision/BulkSync.hs | 36 +++++++++---------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index f4539f70d78..dbddf60eb84 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -219,17 +219,22 @@ fetchDecisionsBulkSyncM peersOrder orderedCandidatesAndPeers - -- If there were no blocks in flight, then this will be the first request, - -- so we take a new current time. case theDecision of Just (_, peerInfo@(_, inflight, _, _, _)) | Set.null (peerFetchBlocksInFlight inflight) + -- If there were no blocks in flight, then this will be the first request, + -- so we take a new current time. -> do peersOrderStart <- getMonotonicTime writePeersOrder $ peersOrder { peersOrderCurrent = Just (peerInfoPeer peerInfo), peersOrderStart } + | Just (peerInfoPeer peerInfo) /= peersOrderCurrent peersOrder + -- If the peer is not the current peer, then we update the current peer + -> + writePeersOrder $ peersOrder + { peersOrderCurrent = Just (peerInfoPeer peerInfo) } _ -> pure () pure $ @@ -275,22 +280,17 @@ fetchDecisionsBulkSyncM ChainSelStarvationEndedAt time -> pure time ChainSelStarvationOngoing -> getMonotonicTime case peersOrderCurrent of - Just peer -> - if lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart - then do - traceWith tracer (PeerStarvedUs peer) - demoteCSJDynamo peer - let peersOrder' = - PeersOrder - { - peersOrderCurrent = Nothing, - peersOrderAll = filter (/= peer) peersOrderAll ++ [peer], - peersOrderStart - } - writePeersOrder peersOrder' - pure peersOrder' - else pure peersOrder - Nothing -> pure peersOrder + Just peer + | lastStarvationTime >= addTime bulkSyncGracePeriod peersOrderStart -> do + traceWith tracer (PeerStarvedUs peer) + demoteCSJDynamo peer + pure PeersOrder + { + peersOrderCurrent = Nothing, + peersOrderAll = filter (/= peer) peersOrderAll ++ [peer], + peersOrderStart + } + _ -> pure peersOrder -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. From 60ea1080ba8e06639c1565b97b3c8f62bffb6c43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Fri, 26 Jul 2024 18:46:50 +0000 Subject: [PATCH 123/136] Change the current peer if it cannot provide the gross request --- .../Network/BlockFetch/Decision/BulkSync.hs | 96 +++++++++---------- 1 file changed, 45 insertions(+), 51 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index dbddf60eb84..766531d2830 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -125,7 +125,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM ) where -import Control.Monad (filterM, guard) +import Control.Monad (guard) import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime), addTime) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) @@ -134,7 +134,7 @@ import Data.Bifunctor (first, Bifunctor (..)) import Data.Function (on) import qualified Data.List as List import qualified Data.Set as Set -import Data.Maybe (maybeToList) +import Data.Maybe (fromMaybe, maybeToList) import Cardano.Prelude (partitionEithers) @@ -463,56 +463,50 @@ selectThePeer let firstBlock = FetchRequest . map (AF.takeOldest 1) . take 1 . filter (not . AF.null) (grossRequest :: FetchRequest header) = firstBlock $ snd theFragments - peersOrderCurrentInfo = do + -- Put the current peer at the front of the list of candidate peers + currentPeerAtFront = fromMaybe candidates $ do currentPeer <- peersOrderCurrent peersOrder - List.find ((currentPeer ==) . peerInfoPeer) $ map snd candidates - - -- If there is a current peer, then that is the one we choose. Otherwise, we - -- can choose any peer, so we choose a “good” one. - case peersOrderCurrentInfo of - Just thePeerInfo -> do - case List.break (((==) `on` peerInfoPeer) thePeerInfo . snd) candidates of - (_, []) -> tell (List [(FetchDeclineChainNotPlausible, thePeerInfo)]) >> return Nothing - (otherPeersB, (thePeerCandidate, _) : otherPeersA) -> do - tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeersB)) - tell (List (map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeersA)) - case checkRequestHeadInCandidate thePeerCandidate grossRequest of - Left reason -> tell (List [(reason, thePeerInfo)]) >> return Nothing - Right () -> return $ Just (thePeerCandidate, thePeerInfo) - - Nothing -> do - -- For each peer, check whether its candidate contains the head of the - -- gross request, otherwise decline it. This will guarantee that the - -- remaining peers can serve the refined request that we will craft later. - peers <- - filterM - ( \(candidate, peer) -> - case checkRequestHeadInCandidate candidate grossRequest of - Left reason -> tell (List [(reason, peer)]) >> pure False - Right () -> pure True - ) - candidates - - -- Return the first peer in that order, and decline all the ones that were - -- not already declined. - case peers of - [] -> return Nothing - (thePeerCandidate, thePeer) : otherPeers -> do - tell $ List $ map (first (const (FetchDeclineConcurrencyLimit FetchModeBulkSync 1))) otherPeers - return $ Just (thePeerCandidate, thePeer) - where - checkRequestHeadInCandidate :: - ChainSuffix header -> FetchRequest header -> FetchDecision () - checkRequestHeadInCandidate candidate request = - case fetchRequestFragments request of - fragments@(_:_) - | AF.withinFragmentBounds - (AF.headPoint $ last fragments) - (getChainSuffix candidate) - -> - Right () - _ -> - Left FetchDeclineAlreadyFetched + (c, xs) <- extract (((currentPeer ==) . peerInfoPeer) . snd) candidates + Just (c : xs) + + -- Return the first peer that can serve the gross request and decline + -- the other peers. + go grossRequest currentPeerAtFront + where + go grossRequest (c@(candidate, peerInfo) : xs) = do + if requestHeadInCandidate candidate grossRequest then do + tell $ List + [(FetchDeclineConcurrencyLimit FetchModeBulkSync 1, pInfo) + | (_, pInfo) <- xs + ] + pure (Just c) + else do + tell $ List [(FetchDeclineAlreadyFetched, peerInfo)] + go grossRequest xs + go _grossRequest [] = pure Nothing + + + requestHeadInCandidate :: ChainSuffix header -> FetchRequest header -> Bool + requestHeadInCandidate candidate request = + case fetchRequestFragments request of + fragments@(_:_) + | AF.withinFragmentBounds + (AF.headPoint $ last fragments) + (getChainSuffix candidate) + -> + True + _ -> + False + +-- | Deletes the first element from the list that satisfies the predicate, and +-- returns the element and the resulting list. +extract :: (a -> Bool) -> [a] -> Maybe (a, [a]) +extract p = go id + where + go _acc [] = Nothing + go acc (x:xs) + | p x = Just (x, acc xs) + | otherwise = go (acc . (x:)) xs -- | Given a candidate and a peer to sync from, create a request for that -- specific peer. We might take the 'FetchDecision' to decline the request, but From 27c819d7f8c321a88c27a3a41f6e1029b3b1119c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Fri, 26 Jul 2024 19:53:47 +0000 Subject: [PATCH 124/136] Put the current peer at the front of the peers order --- .../Network/BlockFetch/ClientState.hs | 2 + .../Network/BlockFetch/Decision/BulkSync.hs | 64 +++++++++---------- 2 files changed, 31 insertions(+), 35 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index d71fab60694..c63d804c12a 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -795,6 +795,8 @@ data PeersOrder peer = PeersOrder -- ^ The current peer we are fetching from, if there is one. , peersOrderAll :: [peer] -- ^ All the peers, from most preferred to least preferred. + -- + -- INVARIANT: If there is a current peer, it is always the head of this list. , peersOrderStart :: Time -- ^ The time at which we started talking to the current peer. } diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 766531d2830..737515fcf8f 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -134,7 +134,7 @@ import Data.Bifunctor (first, Bifunctor (..)) import Data.Function (on) import qualified Data.List as List import qualified Data.Set as Set -import Data.Maybe (fromMaybe, maybeToList) +import Data.Maybe (maybeToList) import Cardano.Prelude (partitionEithers) @@ -216,7 +216,6 @@ fetchDecisionsBulkSyncM currentChain fetchedBlocks fetchedMaxSlotNo - peersOrder orderedCandidatesAndPeers case theDecision of @@ -226,15 +225,12 @@ fetchDecisionsBulkSyncM -- so we take a new current time. -> do peersOrderStart <- getMonotonicTime - writePeersOrder $ peersOrder - { peersOrderCurrent = Just (peerInfoPeer peerInfo), - peersOrderStart - } + writePeersOrder $ setCurrentPeer (peerInfoPeer peerInfo) peersOrder + { peersOrderStart } | Just (peerInfoPeer peerInfo) /= peersOrderCurrent peersOrder -- If the peer is not the current peer, then we update the current peer -> - writePeersOrder $ peersOrder - { peersOrderCurrent = Just (peerInfoPeer peerInfo) } + writePeersOrder $ setCurrentPeer (peerInfoPeer peerInfo) peersOrder _ -> pure () pure $ @@ -251,18 +247,21 @@ fetchDecisionsBulkSyncM peerOf actualPeers PeersOrder {peersOrderStart, peersOrderCurrent, peersOrderAll} = - let peersOrderCurrent' = do - peer <- peersOrderCurrent - guard (any ((peer ==) . peerOf) actualPeers) - pure peer - peersOrderAll' = + let peersOrderAll' = [ d | p <- peersOrderAll , Just d <- [List.find ((p ==) . peerOf) actualPeers] ] ++ filter ((`notElem` peersOrderAll) . peerOf) actualPeers + -- Set the current peer to Nothing if it is not at the front of + -- the list. + peersOrderCurrent' = do + peer <- peersOrderCurrent + guard (any ((peer ==) . peerOf) $ take 1 peersOrderAll') + pure peer in (PeersOrder { peersOrderCurrent = peersOrderCurrent', + -- INVARIANT met: Current peer is at the front if it exists peersOrderAll = map peerOf peersOrderAll', peersOrderStart } @@ -287,24 +286,34 @@ fetchDecisionsBulkSyncM pure PeersOrder { peersOrderCurrent = Nothing, - peersOrderAll = filter (/= peer) peersOrderAll ++ [peer], + -- INVARIANT met: there is no current peer + peersOrderAll = drop 1 peersOrderAll ++ [peer], peersOrderStart } _ -> pure peersOrder + setCurrentPeer :: peer -> PeersOrder peer -> PeersOrder peer + setCurrentPeer peer peersOrder = + case extract ((peer ==)) (peersOrderAll peersOrder) of + Just (p, xs) -> + peersOrder + { peersOrderCurrent = Just p, + -- INVARIANT met: Current peer is at the front + peersOrderAll = p : xs + } + Nothing -> peersOrder {peersOrderCurrent = Nothing} + -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. fetchDecisionsBulkSync :: forall header block peer extra. ( HasHeader header, - HeaderHash header ~ HeaderHash block, - Eq peer + HeaderHash header ~ HeaderHash block ) => FetchDecisionPolicy header -> -- | The current chain, anchored at the immutable tip. AnchoredFragment header -> (Point block -> Bool) -> MaxSlotNo -> - PeersOrder peer -> -- | Association list of the candidate fragments and their associated peers. -- The candidate fragments are anchored in the current chain (not necessarily -- at the tip; and not necessarily forking off immediately). @@ -321,7 +330,6 @@ fetchDecisionsBulkSync currentChain fetchedBlocks fetchedMaxSlotNo - peersOrder candidatesAndPeers = combineWithDeclined $ do -- Step 1: Select the candidate to sync from. This already eliminates peers -- that have an implausible candidate. It returns the remaining candidates @@ -347,11 +355,7 @@ fetchDecisionsBulkSync ( thePeerCandidate :: ChainSuffix header, thePeer :: PeerInfo header peer extra ) <- - MaybeT $ - selectThePeer - peersOrder - theFragments - candidatesAndPeers' + MaybeT $ selectThePeer theFragments candidatesAndPeers' -- Step 4: Fetch the candidate from the selected peer, potentially declining -- it (eg. if the peer is already too busy). @@ -438,10 +442,7 @@ selectTheCandidate -- PRECONDITION: The given candidate fragments must not be empty. selectThePeer :: forall header peer extra. - ( HasHeader header, - Eq peer - ) => - PeersOrder peer -> + HasHeader header => -- | The candidate fragment that we have selected to sync from, as suffix of -- the immutable tip. CandidateFragments header -> @@ -452,7 +453,6 @@ selectThePeer :: (PeerInfo header peer extra) (Maybe (ChainSuffix header, PeerInfo header peer extra)) selectThePeer - peersOrder theFragments candidates = do -- Create a fetch request for the blocks in question. The request has exactly @@ -463,15 +463,9 @@ selectThePeer let firstBlock = FetchRequest . map (AF.takeOldest 1) . take 1 . filter (not . AF.null) (grossRequest :: FetchRequest header) = firstBlock $ snd theFragments - -- Put the current peer at the front of the list of candidate peers - currentPeerAtFront = fromMaybe candidates $ do - currentPeer <- peersOrderCurrent peersOrder - (c, xs) <- extract (((currentPeer ==) . peerInfoPeer) . snd) candidates - Just (c : xs) - -- Return the first peer that can serve the gross request and decline -- the other peers. - go grossRequest currentPeerAtFront + go grossRequest candidates where go grossRequest (c@(candidate, peerInfo) : xs) = do if requestHeadInCandidate candidate grossRequest then do From 4373d13026069e6d02d9f89465dbf8ebcbee1a49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Fri, 26 Jul 2024 19:54:43 +0000 Subject: [PATCH 125/136] Relax the predicates of 'static chains with/out overlap' --- .../sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs index 2f00ef62ac0..a7755843dc2 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs @@ -248,7 +248,10 @@ tracePropertyBlocksRequestedAndRecievedPerPeer fork1 fork2 es = where requiredFetchPoints = if AnchoredFragment.length fork1 == AnchoredFragment.length fork2 - then [requiredFetchPointsFor 1 fork1, requiredFetchPointsFor 2 fork2] + then [ requiredFetchPointsFor 1 fork1 + , requiredFetchPointsFor 2 fork2 + , Map.union (requiredFetchPointsFor 1 fork1) (requiredFetchPointsFor 2 fork2) + ] else if AnchoredFragment.length fork1 < AnchoredFragment.length fork2 then [requiredFetchPointsFor 2 fork2] else [requiredFetchPointsFor 1 fork1] @@ -301,7 +304,10 @@ tracePropertyBlocksRequestedAndRecievedAllPeers fork1 fork2 es = where requiredFetchPoints = if AnchoredFragment.length fork1 == AnchoredFragment.length fork2 - then [requiredFetchPointsFor fork1, requiredFetchPointsFor fork2] + then [ requiredFetchPointsFor fork1 + , requiredFetchPointsFor fork2 + , Set.union (requiredFetchPointsFor fork1) (requiredFetchPointsFor fork2) + ] else if AnchoredFragment.length fork1 < AnchoredFragment.length fork2 then [requiredFetchPointsFor fork2] else [requiredFetchPointsFor fork1] From 0675bfcfc7dc4d06dbfc88e500da09aee077b3d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Fri, 26 Jul 2024 20:05:50 +0000 Subject: [PATCH 126/136] Rename BlockFetch tests that only test BulkSync mode --- .../Test/Ouroboros/Network/BlockFetch.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs index a7755843dc2..3bab001318c 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs @@ -61,11 +61,11 @@ import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) tests :: TestTree tests = testGroup "BlockFetch" - [ testProperty "static chains without overlap" - prop_blockFetchStaticNoOverlap + [ testProperty "BulkSync static chains without overlap" + prop_blockFetchBulkSyncStaticNoOverlap - , testProperty "static chains with overlap" - prop_blockFetchStaticWithOverlap + , testProperty "BulkSync static chains with overlap" + prop_blockFetchBulkSyncStaticWithOverlap , testCaseSteps "bracketSyncWithFetchClient" unit_bracketSyncWithFetchClient @@ -102,8 +102,8 @@ tests = testGroup "BlockFetch" -- * 'tracePropertyClientStateSanity' -- * 'tracePropertyInFlight' -- -prop_blockFetchStaticNoOverlap :: TestChainFork -> Property -prop_blockFetchStaticNoOverlap (TestChainFork common fork1 fork2) = +prop_blockFetchBulkSyncStaticNoOverlap :: TestChainFork -> Property +prop_blockFetchBulkSyncStaticNoOverlap (TestChainFork common fork1 fork2) = let trace = selectTraceEventsDynamic (runSimTrace simulation) in counterexample ("\nTrace:\n" ++ unlines (map show trace)) $ @@ -157,10 +157,10 @@ prop_blockFetchStaticNoOverlap (TestChainFork common fork1 fork2) = -- * 'tracePropertyClientStateSanity' -- * 'tracePropertyInFlight' -- --- TODO: 'prop_blockFetchStaticWithOverlap' fails if we introduce delays. issue #2622 +-- TODO: 'prop_blockFetchBulkSyncStaticWithOverlap' fails if we introduce delays. issue #2622 -- -prop_blockFetchStaticWithOverlap :: TestChainFork -> Property -prop_blockFetchStaticWithOverlap (TestChainFork _common fork1 fork2) = +prop_blockFetchBulkSyncStaticWithOverlap :: TestChainFork -> Property +prop_blockFetchBulkSyncStaticWithOverlap (TestChainFork _common fork1 fork2) = let trace = selectTraceEventsDynamic (runSimTrace simulation) in counterexample ("\nTrace:\n" ++ unlines (map show trace)) $ From 427c92d1e9630f390e404481a4da6be4c626366a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Fri, 26 Jul 2024 22:28:31 +0000 Subject: [PATCH 127/136] fixup: Separate the decision loop interval for bulksync and deadline modes --- ouroboros-network/demo/chain-sync.hs | 3 ++- .../sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs | 3 ++- .../sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs | 3 ++- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 49bd4719557..963c5106e8d 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -513,7 +513,8 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do (BlockFetchConfiguration { bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, - bfcDecisionLoopInterval = 0.01, + bfcDecisionLoopIntervalBulkSync = 0.04, + bfcDecisionLoopIntervalDeadline = 0.01, bfcSalt = 0, bfcGenesisBFConfig = GenesisBlockFetchConfiguration { gbfcBulkSyncGracePeriod = 10 -- seconds diff --git a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs index 2c311772168..1225f13d47c 100644 --- a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -249,7 +249,8 @@ blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer (BlockFetchConfiguration { bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, - bfcDecisionLoopInterval = 0.01, + bfcDecisionLoopIntervalBulkSync = 0.04, + bfcDecisionLoopIntervalDeadline = 0.01, bfcSalt = 0, bfcGenesisBFConfig = GenesisBlockFetchConfiguration { gbfcBulkSyncGracePeriod = 10 -- seconds diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs index 6b75eb1599c..b3cd70cf6bf 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -293,7 +293,8 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = (BlockFetchConfiguration { bfcMaxConcurrencyDeadline = 2, bfcMaxRequestsInflight = 10, - bfcDecisionLoopInterval = 0.01, + bfcDecisionLoopIntervalBulkSync = 0.04, + bfcDecisionLoopIntervalDeadline = 0.01, bfcSalt = 0, bfcGenesisBFConfig = GenesisBlockFetchConfiguration { gbfcBulkSyncGracePeriod = 10 -- seconds From 576a42568be3e1bbb4368263e7c19282207ecc8f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Sat, 27 Jul 2024 14:33:38 +0000 Subject: [PATCH 128/136] Delete extract --- .../Network/BlockFetch/Decision/BulkSync.hs | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 737515fcf8f..b0c30f540db 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -294,14 +294,14 @@ fetchDecisionsBulkSyncM setCurrentPeer :: peer -> PeersOrder peer -> PeersOrder peer setCurrentPeer peer peersOrder = - case extract ((peer ==)) (peersOrderAll peersOrder) of - Just (p, xs) -> + case break ((peer ==)) (peersOrderAll peersOrder) of + (xs, p : ys) -> peersOrder { peersOrderCurrent = Just p, -- INVARIANT met: Current peer is at the front - peersOrderAll = p : xs + peersOrderAll = p : xs ++ ys } - Nothing -> peersOrder {peersOrderCurrent = Nothing} + (_, []) -> peersOrder {peersOrderCurrent = Nothing} -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. @@ -492,16 +492,6 @@ selectThePeer _ -> False --- | Deletes the first element from the list that satisfies the predicate, and --- returns the element and the resulting list. -extract :: (a -> Bool) -> [a] -> Maybe (a, [a]) -extract p = go id - where - go _acc [] = Nothing - go acc (x:xs) - | p x = Just (x, acc xs) - | otherwise = go (acc . (x:)) xs - -- | Given a candidate and a peer to sync from, create a request for that -- specific peer. We might take the 'FetchDecision' to decline the request, but -- only for “good” reasons, eg. if the peer is already too busy. From 441d6d797722e524cbcb1c1b56698386ba1b7274 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 29 Jul 2024 10:24:45 +0000 Subject: [PATCH 129/136] Update the current peer every time it has changed. --- .../Network/BlockFetch/Decision/BulkSync.hs | 20 +++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index b0c30f540db..65185172cd6 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -218,19 +218,22 @@ fetchDecisionsBulkSyncM fetchedMaxSlotNo orderedCandidatesAndPeers + newCurrentPeer = peerInfoPeer . snd <$> theDecision + case theDecision of - Just (_, peerInfo@(_, inflight, _, _, _)) + Just (_, (_, inflight, _, _, _)) | Set.null (peerFetchBlocksInFlight inflight) -- If there were no blocks in flight, then this will be the first request, -- so we take a new current time. -> do peersOrderStart <- getMonotonicTime - writePeersOrder $ setCurrentPeer (peerInfoPeer peerInfo) peersOrder + writePeersOrder $ setCurrentPeer newCurrentPeer peersOrder { peersOrderStart } - | Just (peerInfoPeer peerInfo) /= peersOrderCurrent peersOrder - -- If the peer is not the current peer, then we update the current peer - -> - writePeersOrder $ setCurrentPeer (peerInfoPeer peerInfo) peersOrder + | newCurrentPeer /= peersOrderCurrent peersOrder0 + -- If the new current peer is not the old one, then we update the current + -- peer + -> + writePeersOrder $ setCurrentPeer newCurrentPeer peersOrder _ -> pure () pure $ @@ -292,8 +295,9 @@ fetchDecisionsBulkSyncM } _ -> pure peersOrder - setCurrentPeer :: peer -> PeersOrder peer -> PeersOrder peer - setCurrentPeer peer peersOrder = + setCurrentPeer :: Maybe peer -> PeersOrder peer -> PeersOrder peer + setCurrentPeer Nothing peersOrder = peersOrder {peersOrderCurrent = Nothing} + setCurrentPeer (Just peer) peersOrder = case break ((peer ==)) (peersOrderAll peersOrder) of (xs, p : ys) -> peersOrder From 69986a27cfb7c53c1923d93c2ded3af5a68b8051 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 29 Jul 2024 13:29:31 +0000 Subject: [PATCH 130/136] Adjust documentation after putting the current peer at the front of peersOrder --- .../Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 65185172cd6..f72cefeaaf6 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -47,15 +47,14 @@ -- candidate header chain among the ChainSync clients (eg. best raw -- tiebreaker among the longest). -- --- 2. Select @thePeer :: peer@. If @inflight(currentPeer)@ is not empty, then --- this is @currentPeer@. Otherwise: +-- 2. Select @thePeer :: peer@. -- -- - Let @grossRequest@ be the oldest block on @theCandidate@ that has not -- already been downloaded. -- -- - If @grossRequest@ is empty, then terminate this iteration. Otherwise, --- pick the best peer (according to @peersOrder@) offering the --- block in @grossRequest@. +-- pick the best peer (according to @peersOrder@) offering the block in +-- @grossRequest@. -- -- 3. Craft the actual request to @thePeer@ asking blocks of @theCandidate@: -- @@ -66,7 +65,8 @@ -- which blocks are actually already currently in-flight with @thePeer@. -- -- 4. If we went through the election of a new peer, replace @currentPeer@ and --- reset @currentStart@. +-- put the new peer at the front of @peersOrder@. Also reset @currentStart@ +-- if @inflights(thePeer)@ is empty. -- -- Terminate this iteration. -- From 9ad28ad983a5946081ef72cb3fa52763e0d5f4c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Tue, 30 Jul 2024 17:57:21 +0000 Subject: [PATCH 131/136] Flip calls to align peers and check starvation --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index f72cefeaaf6..b28584085e3 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -200,13 +200,13 @@ fetchDecisionsBulkSyncM demoteCSJDynamo ) candidatesAndPeers = do - let (peersOrder1, orderedCandidatesAndPeers) = + peersOrder1 <- checkLastChainSelStarvation peersOrder0 + + let (peersOrder, orderedCandidatesAndPeers) = alignPeersOrderWithActualPeers (peerInfoPeer . snd) candidatesAndPeers - peersOrder0 - - peersOrder <- checkLastChainSelStarvation peersOrder1 + peersOrder1 -- Compute the actual block fetch decision. This contains only declines and -- at most one request. 'theDecision' is therefore a 'Maybe'. From 6438401ec20dc98e29ac5f70e27422b502f8eadb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Tue, 30 Jul 2024 18:29:14 +0000 Subject: [PATCH 132/136] Run the BlockFetch logic at least once every grace period --- .../src/Ouroboros/Network/BlockFetch.hs | 2 +- .../src/Ouroboros/Network/BlockFetch/State.hs | 26 ++++++++++++++----- 2 files changed, 20 insertions(+), 8 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index 4b641afa304..e852cb0b815 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -176,7 +176,7 @@ blockFetchLogic :: forall addr header block m. , HasHeader block , HeaderHash header ~ HeaderHash block , MonadDelay m - , MonadSTM m + , MonadTimer m , Ord addr , Hashable addr ) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 6682257f9a3..36679d4522b 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -24,6 +24,7 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Void +import qualified Control.Monad.Class.MonadSTM.Internal as Internal.TVar import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked (newTVarIO, StrictTVar, readTVarIO, writeTVar) import Control.Exception (assert) import Control.Monad.Class.MonadSTM @@ -51,7 +52,7 @@ fetchLogicIterations , HasHeader block , HeaderHash header ~ HeaderHash block , MonadDelay m - , MonadSTM m + , MonadTimer m , Ord peer , Hashable peer ) @@ -111,10 +112,10 @@ iterateForever x0 m = go x0 where go x = m x >>= go -- * deciding for each peer if we will initiate a new fetch request -- fetchLogicIteration - :: (Hashable peer, MonadSTM m, Ord peer, + :: (Hashable peer, Ord peer, HasHeader header, HasHeader block, HeaderHash header ~ HeaderHash block, - MonadMonotonicTime m) + MonadTimer m) => Tracer m (TraceDecisionEvent peer header) -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) -> FetchDecisionPolicy header @@ -131,17 +132,24 @@ fetchLogicIteration decisionTracer clientStateTracer (peersOrderVar, demoteCSJDynamo) = do -- Gather a snapshot of all the state we need. - (stateSnapshot, stateFingerprint') <- + -- + -- The grace period is considered to retrigger the decision logic even + -- if no state has changed. This can help downloading blocks from a + -- different peer if all ChainSync clients are blocked on the forecast + -- horizon and the current peer of BlockFetch is not sending blocks. + gracePeriodTVar <- registerDelay (bulkSyncGracePeriod fetchDecisionPolicy) + (stateSnapshot, gracePeriodExpired, stateFingerprint') <- atomically $ readStateVariables fetchTriggerVariables fetchNonTriggerVariables + gracePeriodTVar stateFingerprint peersOrder <- readTVarIO peersOrderVar -- TODO: allow for boring PeerFetchStatusBusy transitions where we go round -- again rather than re-evaluating everything. - assert (stateFingerprint' /= stateFingerprint) $ return () + assert (gracePeriodExpired || stateFingerprint' /= stateFingerprint) $ return () -- TODO: log the difference in the fingerprint that caused us to wake up @@ -342,17 +350,21 @@ readStateVariables :: (MonadSTM m, Eq peer, HeaderHash header ~ HeaderHash block) => FetchTriggerVariables peer header m -> FetchNonTriggerVariables peer header block m + -> Internal.TVar.TVar m Bool -> FetchStateFingerprint peer header block -> STM m (FetchStateSnapshot peer header block m, + Bool, FetchStateFingerprint peer header block) readStateVariables FetchTriggerVariables{..} FetchNonTriggerVariables{..} + gracePeriodTVar fetchStateFingerprint = do -- Read all the trigger state variables fetchStateCurrentChain <- readStateCurrentChain fetchStatePeerChains <- readStateCandidateChains fetchStatePeerStatus <- readStatePeerStatus + gracePeriodExpired <- Internal.TVar.readTVar gracePeriodTVar -- Construct the change detection fingerprint let !fetchStateFingerprint' = @@ -362,7 +374,7 @@ readStateVariables FetchTriggerVariables{..} fetchStatePeerStatus -- Check the fingerprint changed, or block and wait until it does - check (fetchStateFingerprint' /= fetchStateFingerprint) + check (gracePeriodExpired || fetchStateFingerprint' /= fetchStateFingerprint) -- Now read all the non-trigger state variables fetchStatePeerStates <- readStatePeerStateVars @@ -386,4 +398,4 @@ readStateVariables FetchTriggerVariables{..} fetchStateChainSelStarvation } - return (fetchStateSnapshot, fetchStateFingerprint') + return (fetchStateSnapshot, gracePeriodExpired, fetchStateFingerprint') From 61626448c83c257413309d0cf86dab72dafee899 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Tue, 30 Jul 2024 19:40:25 +0000 Subject: [PATCH 133/136] Use compareCandidateChains to select a chain in BulkSync BlockFetch --- .../Network/BlockFetch/Decision/BulkSync.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index b28584085e3..ae2085d2098 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -131,14 +131,13 @@ import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) import Control.Tracer (Tracer, traceWith) import Data.Bifunctor (first, Bifunctor (..)) -import Data.Function (on) import qualified Data.List as List import qualified Data.Set as Set import Data.Maybe (maybeToList) import Cardano.Prelude (partitionEithers) -import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headBlockNo) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState @@ -409,7 +408,7 @@ selectTheCandidate :: peerInfo (Maybe (ChainSuffix header, [(ChainSuffix header, peerInfo)])) selectTheCandidate - FetchDecisionPolicy {plausibleCandidateChain} + FetchDecisionPolicy {compareCandidateChains, plausibleCandidateChain} currentChain = separateDeclinedAndStillInRace -- Select the suffix up to the intersection with the current chain. This can @@ -430,8 +429,13 @@ selectTheCandidate case inRace of [] -> pure Nothing _ : _ -> do - let chainSfx = fst $ - List.maximumBy (compare `on` (headBlockNo . getChainSuffix . fst)) inRace + let maxChainOn f c0 c1 = case compareCandidateChains (f c0) (f c1) of + LT -> c1 + _ -> c0 + -- maximumBy yields the last element in case of a tie while we + -- prefer the first one + chainSfx = fst $ + List.foldl1' (maxChainOn (getChainSuffix . fst)) inRace pure $ Just (chainSfx, inRace) -- | Given _the_ candidate fragment to sync from, and a list of peers (with From 45ec560ed00cdf21d6e0f7ccf5fb285b82b6530b Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 1 Aug 2024 14:30:25 +0200 Subject: [PATCH 134/136] Replace custom type ListConcat with DList --- ouroboros-network/ouroboros-network.cabal | 1 + .../Network/BlockFetch/Decision/BulkSync.hs | 34 ++++++------------- 2 files changed, 11 insertions(+), 24 deletions(-) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index bd538536838..694b89fdc09 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -116,6 +116,7 @@ library cborg >=0.2.1 && <0.3, containers, deepseq, + dlist, dns, hashable, iproute, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index ae2085d2098..f95a293743e 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -131,6 +131,8 @@ import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) import Control.Tracer (Tracer, traceWith) import Data.Bifunctor (first, Bifunctor (..)) +import Data.DList (DList) +import qualified Data.DList as DList import qualified Data.List as List import qualified Data.Set as Set import Data.Maybe (maybeToList) @@ -149,25 +151,9 @@ import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation(..)) import Ouroboros.Network.BlockFetch.Decision.Deadline import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..)) --- | A trivial foldable data structure with a 'Semigroup' instance that --- concatenates in @O(1)@. Only meant for short-term use, followed by one fold. -data ListConcat a = List [a] | Concat (ListConcat a) (ListConcat a) +type WithDeclined peer = Writer (DList (FetchDecline, peer)) -instance Semigroup (ListConcat a) where - (<>) = Concat - -instance Monoid (ListConcat a) where - mempty = List [] - -listConcatToList :: ListConcat a -> [a] -listConcatToList = flip go [] - where - go (List xs) acc = xs ++ acc - go (Concat x y) acc = go x (go y acc) - -type WithDeclined peer = Writer (ListConcat (FetchDecline, peer)) - -runWithDeclined :: WithDeclined peer a -> (a, ListConcat (FetchDecline, peer)) +runWithDeclined :: WithDeclined peer a -> (a, DList (FetchDecline, peer)) runWithDeclined = runWriter fetchDecisionsBulkSyncM @@ -374,7 +360,7 @@ fetchDecisionsBulkSync ( Maybe (a, peerInfo), [(FetchDecline, peerInfo)] ) - combineWithDeclined = second listConcatToList . runWithDeclined . runMaybeT + combineWithDeclined = second DList.toList . runWithDeclined . runMaybeT dropAlreadyFetchedBlocks :: forall peerInfo. [(ChainSuffix header, peerInfo)] -> @@ -383,7 +369,7 @@ fetchDecisionsBulkSync dropAlreadyFetchedBlocks candidatesAndPeers' theCandidate = case dropAlreadyFetched fetchedBlocks fetchedMaxSlotNo theCandidate of Left reason -> do - tell (List [(reason, peerInfo) | (_, peerInfo) <- candidatesAndPeers']) + tell (DList.fromList [(reason, peerInfo) | (_, peerInfo) <- candidatesAndPeers']) pure Nothing Right theFragments -> pure (Just theFragments) @@ -425,7 +411,7 @@ selectTheCandidate separateDeclinedAndStillInRace decisions = do let (declined, inRace) = partitionEithers [ bimap ((,p)) ((,p)) d | (d, p) <- decisions ] - tell (List declined) + tell (DList.fromList declined) case inRace of [] -> pure Nothing _ : _ -> do @@ -477,13 +463,13 @@ selectThePeer where go grossRequest (c@(candidate, peerInfo) : xs) = do if requestHeadInCandidate candidate grossRequest then do - tell $ List + tell $ DList.fromList [(FetchDeclineConcurrencyLimit FetchModeBulkSync 1, pInfo) | (_, pInfo) <- xs ] pure (Just c) else do - tell $ List [(FetchDeclineAlreadyFetched, peerInfo)] + tell $ DList.fromList [(FetchDeclineAlreadyFetched, peerInfo)] go grossRequest xs go _grossRequest [] = pure Nothing @@ -540,7 +526,7 @@ makeFetchRequest status (Right trimmedFragments) in case theDecision of - Left reason -> tell (List [(reason, thePeer)]) >> pure Nothing + Left reason -> tell (DList.fromList [(reason, thePeer)]) >> pure Nothing Right theRequest -> pure $ Just (theRequest, thePeer) where trimFragmentsToCandidate candidate fragments = From 12a0f1f68a740f9775c92d1f5ad744ee173e867b Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 1 Aug 2024 18:51:54 +0200 Subject: [PATCH 135/136] use `Seq` instead of `List` for `peersOrderAll` --- .../Network/BlockFetch/ClientState.hs | 11 +++--- .../Network/BlockFetch/Decision/BulkSync.hs | 36 ++++++++++--------- .../src/Ouroboros/Network/BlockFetch/State.hs | 3 +- 3 files changed, 28 insertions(+), 22 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index c63d804c12a..9656ace0887 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -40,6 +40,7 @@ module Ouroboros.Network.BlockFetch.ClientState import Data.List (foldl') import Data.Maybe (mapMaybe) import Data.Semigroup (Last (..)) +import Data.Sequence (Seq, (|>), (<|)) import Data.Set (Set) import Control.Concurrent.Class.MonadSTM.Strict @@ -793,7 +794,7 @@ tryReadTMergeVar (TMergeVar v) = tryReadTMVar v data PeersOrder peer = PeersOrder { peersOrderCurrent :: Maybe peer -- ^ The current peer we are fetching from, if there is one. - , peersOrderAll :: [peer] + , peersOrderAll :: Seq peer -- ^ All the peers, from most preferred to least preferred. -- -- INVARIANT: If there is a current peer, it is always the head of this list. @@ -801,10 +802,10 @@ data PeersOrder peer = PeersOrder -- ^ The time at which we started talking to the current peer. } -mcons :: Maybe a -> [a] -> [a] +mcons :: Maybe a -> Seq a -> Seq a mcons Nothing xs = xs -mcons (Just x) xs = x : xs +mcons (Just x) xs = x <| xs -msnoc :: [a] -> Maybe a -> [a] +msnoc :: Seq a -> Maybe a -> Seq a msnoc xs Nothing = xs -msnoc xs (Just x) = xs ++ [x] +msnoc xs (Just x) = xs |> x diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index f95a293743e..226e68cda58 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -131,9 +132,12 @@ import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Control.Monad.Writer.Strict (Writer, runWriter, MonadWriter (tell)) import Control.Tracer (Tracer, traceWith) import Data.Bifunctor (first, Bifunctor (..)) +import Data.Foldable (toList) import Data.DList (DList) import qualified Data.DList as DList import qualified Data.List as List +import Data.Sequence (Seq (..), (><), (<|), (|>)) +import qualified Data.Sequence as Sequence import qualified Data.Set as Set import Data.Maybe (maybeToList) @@ -190,7 +194,7 @@ fetchDecisionsBulkSyncM let (peersOrder, orderedCandidatesAndPeers) = alignPeersOrderWithActualPeers (peerInfoPeer . snd) - candidatesAndPeers + (Sequence.fromList candidatesAndPeers) peersOrder1 -- Compute the actual block fetch decision. This contains only declines and @@ -201,7 +205,7 @@ fetchDecisionsBulkSyncM currentChain fetchedBlocks fetchedMaxSlotNo - orderedCandidatesAndPeers + (toList orderedCandidatesAndPeers) newCurrentPeer = peerInfoPeer . snd <$> theDecision @@ -230,27 +234,27 @@ fetchDecisionsBulkSyncM -- adding at the end of the peers order all the actual peers that were not -- there before. alignPeersOrderWithActualPeers :: forall d. - (d -> peer) -> [d] -> PeersOrder peer -> (PeersOrder peer, [d]) + (d -> peer) -> Seq d -> PeersOrder peer -> (PeersOrder peer, Seq d) alignPeersOrderWithActualPeers peerOf actualPeers PeersOrder {peersOrderStart, peersOrderCurrent, peersOrderAll} = - let peersOrderAll' = - [ d - | p <- peersOrderAll - , Just d <- [List.find ((p ==) . peerOf) actualPeers] - ] - ++ filter ((`notElem` peersOrderAll) . peerOf) actualPeers + let peersOrderAll' = ( do + p <- peersOrderAll + case List.find ((p ==) . peerOf) actualPeers of + Just d -> pure d + Nothing -> Empty + ) >< Sequence.filter ((`notElem` peersOrderAll) . peerOf) actualPeers -- Set the current peer to Nothing if it is not at the front of -- the list. peersOrderCurrent' = do peer <- peersOrderCurrent - guard (any ((peer ==) . peerOf) $ take 1 peersOrderAll') + guard (any ((peer ==) . peerOf) $ Sequence.take 1 peersOrderAll') pure peer in (PeersOrder { peersOrderCurrent = peersOrderCurrent', -- INVARIANT met: Current peer is at the front if it exists - peersOrderAll = map peerOf peersOrderAll', + peersOrderAll = fmap peerOf peersOrderAll', peersOrderStart } , peersOrderAll' @@ -275,7 +279,7 @@ fetchDecisionsBulkSyncM { peersOrderCurrent = Nothing, -- INVARIANT met: there is no current peer - peersOrderAll = drop 1 peersOrderAll ++ [peer], + peersOrderAll = Sequence.drop 1 peersOrderAll |> peer, peersOrderStart } _ -> pure peersOrder @@ -283,14 +287,14 @@ fetchDecisionsBulkSyncM setCurrentPeer :: Maybe peer -> PeersOrder peer -> PeersOrder peer setCurrentPeer Nothing peersOrder = peersOrder {peersOrderCurrent = Nothing} setCurrentPeer (Just peer) peersOrder = - case break ((peer ==)) (peersOrderAll peersOrder) of - (xs, p : ys) -> + case Sequence.breakl ((peer ==)) (peersOrderAll peersOrder) of + (xs, p :<| ys) -> peersOrder { peersOrderCurrent = Just p, -- INVARIANT met: Current peer is at the front - peersOrderAll = p : xs ++ ys + peersOrderAll = p <| xs >< ys } - (_, []) -> peersOrder {peersOrderCurrent = Nothing} + (_, Empty) -> peersOrder {peersOrderCurrent = Nothing} -- | Given a list of candidate fragments and their associated peers, choose what -- to sync from who in the bulk sync mode. diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 36679d4522b..799e9396197 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -21,6 +21,7 @@ import Data.Functor.Contravariant (contramap) import Data.Hashable (Hashable) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Sequence (Seq (Empty)) import Data.Set qualified as Set import Data.Void @@ -72,7 +73,7 @@ fetchLogicIterations decisionTracer clientStateTracer peersOrderVar <- newTVarIO $ PeersOrder { peersOrderCurrent = Nothing, peersOrderStart = Time 0, - peersOrderAll = [] + peersOrderAll = Empty } iterateForever initialFetchStateFingerprint $ \stateFingerprint -> do From 9abfde54d08f1225f35f9cefd7021a9bb2320559 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 1 Aug 2024 19:56:33 +0200 Subject: [PATCH 136/136] Replace filter by assertion when building gross request --- .../src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs index 226e68cda58..e37e990a257 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/BulkSync.hs @@ -126,6 +126,7 @@ module Ouroboros.Network.BlockFetch.Decision.BulkSync ( fetchDecisionsBulkSyncM ) where +import Control.Exception (assert) import Control.Monad (guard) import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime), addTime) import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) @@ -457,9 +458,10 @@ selectThePeer -- 1 block. It will only be used to choose the peer to fetch from, but we will -- later craft a more refined request for that peer. See [About the gross -- request] in the module documentation. Because @theFragments@ is not - -- empty, @grossRequest@ will not be empty. - let firstBlock = FetchRequest . map (AF.takeOldest 1) . take 1 . filter (not . AF.null) - (grossRequest :: FetchRequest header) = firstBlock $ snd theFragments + -- empty, and does not contain empty fragments, @grossRequest@ will not be empty. + let firstBlock = map (AF.takeOldest 1) . take 1 . filter (not . AF.null) + requestBlock = firstBlock $ snd theFragments + grossRequest = FetchRequest $ assert (all (not . AF.null) requestBlock) requestBlock -- Return the first peer that can serve the gross request and decline -- the other peers.