From 947f9b8ad41775c9488127189216b76aaab3108a Mon Sep 17 00:00:00 2001 From: Damian Nadales Date: Wed, 6 Nov 2024 13:34:03 +0100 Subject: [PATCH] Add an extra header parameter to BlockFetchConsensusInterface This parameter is currently called `selectionHeader`. This change allow us to use two header types in the interface. The `header` type, now is intended to convey additional information, in particular the slot time at which the header was downloaded. In this way we can address [this issue](https://github.com/IntersectMBO/ouroboros-consensus/issues/1301) which allow us to simplify Consensus time conversions. Additionally, this change will enable us to remove `FromConsensus` data and the precondition of `headerForgeUTCTime`. The `selectionHeader` type will typically denote a raw header. --- .../Network/BlockFetch/ConsensusInterface.hs | 7 +-- ouroboros-network/demo/chain-sync.hs | 2 +- .../Ouroboros/Network/BlockFetch/Examples.hs | 2 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 2 +- .../src/Ouroboros/Network/BlockFetch.hs | 12 ++--- .../Ouroboros/Network/BlockFetch/Decision.hs | 39 ++++++++-------- .../src/Ouroboros/Network/BlockFetch/State.hs | 45 +++++++++++-------- 7 files changed, 62 insertions(+), 47 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index c804383819c..cd8158f7718 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -47,7 +47,8 @@ data FetchMode = -- -- These are provided as input to the block fetch by the consensus layer. -- -data BlockFetchConsensusInterface peer header block m = +-- REVIEW: Explain why we have two types of headers. +data BlockFetchConsensusInterface peer selectionHeader header block m = BlockFetchConsensusInterface { -- | Read the K-suffixes of the candidate chains. @@ -63,7 +64,7 @@ data BlockFetchConsensusInterface peer header block m = -- This must contain info on the last @K@ blocks (unless we're near -- the chain genesis of course). -- - readCurrentChain :: STM m (AnchoredFragment header), + readCurrentChain :: STM m (AnchoredFragment selectionHeader), -- | Read the current fetch mode that the block fetch logic should use. -- @@ -105,7 +106,7 @@ data BlockFetchConsensusInterface peer header block m = -- we would consider a chain of equal length to the current chain. -- plausibleCandidateChain :: HasCallStack - => AnchoredFragment header + => AnchoredFragment selectionHeader -> AnchoredFragment header -> Bool, -- | Compare two candidate chains and return a preference ordering. diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 4c7acd3935a..7c505a7c30b 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -418,7 +418,7 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do nullTracer clientCtx) blockFetchPolicy :: BlockFetchConsensusInterface - LocalConnectionId BlockHeader Block IO + LocalConnectionId BlockHeader BlockHeader Block IO blockFetchPolicy = BlockFetchConsensusInterface { readCandidateChains = readTVar candidateChainsVar 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 fe9ae05d75e..6b03039641a 100644 --- a/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/sim-tests-lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -272,7 +272,7 @@ sampleBlockFetchPolicy1 :: (MonadSTM m, HasHeader header, HasHeader block) -> TestFetchedBlockHeap m block -> AnchoredFragment header -> Map peer (AnchoredFragment header) - -> BlockFetchConsensusInterface peer header block m + -> BlockFetchConsensusInterface peer header header block m sampleBlockFetchPolicy1 headerFieldsForgeUTCTime blockHeap currentChain candidateChains = BlockFetchConsensusInterface { readCandidateChains = return candidateChains, 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 4dbd322069e..289f33e63c3 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 @@ -298,7 +298,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = }) blockFetchPolicy :: NodeKernel BlockHeader Block s m - -> BlockFetchConsensusInterface NtNAddr BlockHeader Block m + -> BlockFetchConsensusInterface NtNAddr BlockHeader BlockHeader Block m blockFetchPolicy nodeKernel = BlockFetchConsensusInterface { readCandidateChains = readTVar (nkClientChains nodeKernel) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index 86d0fecea8b..373bcf904de 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -152,9 +152,11 @@ data BlockFetchConfiguration = -- -- This runs forever and should be shut down using mechanisms such as async. -- -blockFetchLogic :: forall addr header block m. - ( HasHeader header +blockFetchLogic :: forall addr selectionHeader header block m. + ( HasHeader selectionHeader + , HasHeader header , HasHeader block + , HeaderHash selectionHeader ~ HeaderHash block , HeaderHash header ~ HeaderHash block , MonadDelay m , MonadSTM m @@ -163,7 +165,7 @@ blockFetchLogic :: forall addr header block m. ) => Tracer m [TraceLabelPeer addr (FetchDecision [Point header])] -> Tracer m (TraceLabelPeer addr (TraceFetchClientState header)) - -> BlockFetchConsensusInterface addr header block m + -> BlockFetchConsensusInterface addr selectionHeader header block m -> FetchClientRegistry addr header block m -> BlockFetchConfiguration -> m Void @@ -190,7 +192,7 @@ blockFetchLogic decisionTracer clientStateTracer blockForgeUTCTime } - fetchDecisionPolicy :: FetchDecisionPolicy header + fetchDecisionPolicy :: FetchDecisionPolicy selectionHeader header fetchDecisionPolicy = FetchDecisionPolicy { maxInFlightReqsPerPeer = bfcMaxRequestsInflight, @@ -204,7 +206,7 @@ blockFetchLogic decisionTracer clientStateTracer blockFetchSize } - fetchTriggerVariables :: FetchTriggerVariables addr header m + fetchTriggerVariables :: FetchTriggerVariables addr selectionHeader header m fetchTriggerVariables = FetchTriggerVariables { readStateCurrentChain = readCurrentChain, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index bbc6ba47f83..e50cbff0fa1 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -50,7 +50,7 @@ import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), estimateResponseDeadlineProbability) -data FetchDecisionPolicy header = FetchDecisionPolicy { +data FetchDecisionPolicy selectionHeader header = FetchDecisionPolicy { maxInFlightReqsPerPeer :: Word, -- A protocol constant. maxConcurrencyBulkSync :: Word, @@ -59,7 +59,7 @@ data FetchDecisionPolicy header = FetchDecisionPolicy { peerSalt :: Int, plausibleCandidateChain :: HasCallStack - => AnchoredFragment header + => AnchoredFragment selectionHeader -> AnchoredFragment header -> Bool, compareCandidateChains :: HasCallStack @@ -251,10 +251,13 @@ fetchDecisions :: (Ord peer, Hashable peer, HasHeader header, - HeaderHash header ~ HeaderHash block) - => FetchDecisionPolicy header + HeaderHash header ~ HeaderHash block, + HeaderHash selectionHeader ~ HeaderHash block, + HasHeader selectionHeader + ) + => FetchDecisionPolicy selectionHeader header -> FetchMode - -> AnchoredFragment header + -> AnchoredFragment selectionHeader -> (Point block -> Bool) -> MaxSlotNo -> [(AnchoredFragment header, PeerInfo header peer extra)] @@ -399,8 +402,8 @@ current chain. So our first task is to filter down to this set. -- the current chain. -- filterPlausibleCandidates - :: (AnchoredFragment block -> AnchoredFragment header -> Bool) - -> AnchoredFragment block -- ^ The current chain + :: (AnchoredFragment selectionHeader -> AnchoredFragment header -> Bool) + -> AnchoredFragment selectionHeader -- ^ The current chain -> [(AnchoredFragment header, peerinfo)] -> [(FetchDecision (AnchoredFragment header), peerinfo)] filterPlausibleCandidates plausibleCandidateChain currentChain chains = @@ -507,11 +510,11 @@ interested in this candidate at all. -- current chain. -- chainForkSuffix - :: (HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) - => AnchoredFragment block -- ^ Current chain. - -> AnchoredFragment header -- ^ Candidate chain - -> Maybe (ChainSuffix header) + :: (HasHeader header1, HasHeader header2, + HeaderHash header1 ~ HeaderHash header2) + => AnchoredFragment header2 -- ^ Current chain. + -> AnchoredFragment header1 -- ^ Candidate chain + -> Maybe (ChainSuffix header1) chainForkSuffix current candidate = case AF.intersect current candidate of Nothing -> Nothing @@ -523,9 +526,9 @@ chainForkSuffix current candidate = Just (ChainSuffix candidateSuffix) selectForkSuffixes - :: (HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) - => AnchoredFragment block + :: (HasHeader selectionHeader, HasHeader header, + HeaderHash selectionHeader ~ HeaderHash header) + => AnchoredFragment selectionHeader -> [(FetchDecision (AnchoredFragment header), peerinfo)] -> [(FetchDecision (ChainSuffix header), peerinfo)] selectForkSuffixes current chains = @@ -889,12 +892,12 @@ obviously take that into account when considering later peer chains. fetchRequestDecisions - :: forall extra header peer. + :: forall extra selectionHeader header peer. ( Hashable peer , HasHeader header , Ord peer ) - => FetchDecisionPolicy header + => FetchDecisionPolicy selectionHeader header -> FetchMode -> [( FetchDecision [AnchoredFragment header] , PeerFetchStatus header @@ -1009,7 +1012,7 @@ fetchRequestDecisions fetchDecisionPolicy fetchMode chains = fetchRequestDecision :: HasHeader header - => FetchDecisionPolicy header + => FetchDecisionPolicy selectionHeader header -> FetchMode -> Word -> PeerFetchInFlightLimits diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 6f072fe035d..48c318baee8 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -45,9 +45,11 @@ import Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..)) fetchLogicIterations - :: ( HasHeader header + :: ( HasHeader selectionHeader , HasHeader block + , HeaderHash selectionHeader ~ HeaderHash block , HeaderHash header ~ HeaderHash block + , HasHeader header , MonadDelay m , MonadSTM m , Ord peer @@ -55,8 +57,8 @@ fetchLogicIterations ) => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])] -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) - -> FetchDecisionPolicy header - -> FetchTriggerVariables peer header m + -> FetchDecisionPolicy selectionHeader header + -> FetchTriggerVariables peer selectionHeader header m -> FetchNonTriggerVariables peer header block m -> m Void fetchLogicIterations decisionTracer clientStateTracer @@ -98,12 +100,15 @@ 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, + HasHeader header, + HasHeader selectionHeader, HasHeader block, + HeaderHash selectionHeader ~ HeaderHash block + ) => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])] -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) - -> FetchDecisionPolicy header - -> FetchTriggerVariables peer header m + -> FetchDecisionPolicy selectionHeader header + -> FetchTriggerVariables peer selectionHeader header m -> FetchNonTriggerVariables peer header block m -> FetchStateFingerprint peer header block -> m (FetchStateFingerprint peer header block) @@ -163,11 +168,13 @@ fetchLogicIteration decisionTracer clientStateTracer -- fetchDecisionsForStateSnapshot :: (HasHeader header, + HasHeader selectionHeader, + HeaderHash selectionHeader ~ HeaderHash block, HeaderHash header ~ HeaderHash block, Ord peer, Hashable peer) - => FetchDecisionPolicy header - -> FetchStateSnapshot peer header block m + => FetchDecisionPolicy selectionHeader header + -> FetchStateSnapshot peer selectionHeader header block m -> [( FetchDecision (FetchRequest header), PeerInfo header peer (FetchClientStateVars m header, peer) )] @@ -213,7 +220,7 @@ fetchDecisionsForStateSnapshot -- fetchLogicIterationAct :: (MonadSTM m, HasHeader header) => Tracer m (TraceLabelPeer peer (TraceFetchClientState header)) - -> FetchDecisionPolicy header + -> FetchDecisionPolicy selectionHeader header -> [(FetchDecision (FetchRequest header), PeerGSV, FetchClientStateVars m header, @@ -240,8 +247,8 @@ fetchLogicIterationAct clientStateTracer FetchDecisionPolicy{blockFetchSize} -- and it is not necessary to determine exactly what changed, just that there -- was some change. -- -data FetchTriggerVariables peer header m = FetchTriggerVariables { - readStateCurrentChain :: STM m (AnchoredFragment header), +data FetchTriggerVariables peer selectionHeader header m = FetchTriggerVariables { + readStateCurrentChain :: STM m (AnchoredFragment selectionHeader), readStateCandidateChains :: STM m (Map peer (AnchoredFragment header)), readStatePeerStatus :: STM m (Map peer (PeerFetchStatus header)) } @@ -289,8 +296,8 @@ updateFetchStateFingerprintPeerStatus statuses' -- Note that the domain of 'fetchStatePeerChains' is a subset of the domain -- of 'fetchStatePeerStates' and 'fetchStatePeerReqVars'. -- -data FetchStateSnapshot peer header block m = FetchStateSnapshot { - fetchStateCurrentChain :: AnchoredFragment header, +data FetchStateSnapshot peer selectionHeader header block m = FetchStateSnapshot { + fetchStateCurrentChain :: AnchoredFragment selectionHeader, fetchStatePeerChains :: Map peer (AnchoredFragment header), fetchStatePeerStates :: Map peer (PeerFetchStatus header, PeerFetchInFlight header, @@ -302,12 +309,14 @@ data FetchStateSnapshot peer header block m = FetchStateSnapshot { } readStateVariables :: (MonadSTM m, Eq peer, - HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) - => FetchTriggerVariables peer header m + HasHeader selectionHeader, HasHeader block, + HeaderHash selectionHeader ~ HeaderHash block, + HasHeader header + ) + => FetchTriggerVariables peer selectionHeader header m -> FetchNonTriggerVariables peer header block m -> FetchStateFingerprint peer header block - -> STM m (FetchStateSnapshot peer header block m, + -> STM m (FetchStateSnapshot peer selectionHeader header block m, FetchStateFingerprint peer header block) readStateVariables FetchTriggerVariables{..} FetchNonTriggerVariables{..}