Ensure that compared fragments always intersect

Author: amesgen

ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs

@@ -212,6 +212,8 @@ data ChainComparison header =
        -- This is used as part of selecting which chains to prioritise for
        -- downloading block bodies.
        --
+       -- PRECONDITION: The two fragments must intersect.
+       --
        compareCandidateChains  :: HasCallStack
                                => AnchoredFragment header
                                -> AnchoredFragment header

ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs

@@ -33,7 +33,7 @@ import Data.Set qualified as Set
 import Data.Function (on)
 import Data.Hashable
 import Data.List as List (foldl', groupBy, sortBy, transpose)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Set (Set)
 
 import Control.Exception (assert)
@@ -473,8 +473,11 @@ empty fetch range, but this is ok since we never request empty ranges.
 --
 -- 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 }
+data ChainSuffix header = ChainSuffix {
+   getChainSuffix                  :: !(AnchoredFragment header)
+ , -- | TODO
+   getChainSuffixAfterImmutableTip :: !(AnchoredFragment header)
+ }
 
 {-
 We define the /chain suffix/ as the suffix of the candidate chain up until (but
@@ -511,25 +514,27 @@ 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
+  :: HasHeader header
+  => AnchoredFragment header
+  -> AnchoredFragment header
   -> Maybe (ChainSuffix header)
 chainForkSuffix current candidate =
     case AF.intersect current candidate of
       Nothing                         -> Nothing
-      Just (_, _, _, candidateSuffix) ->
+      Just (currentPrefix, _, _, 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)
+        Just (ChainSuffix candidateSuffix candidateSuffixAfterImmTip)
+        where
+          candidateSuffixAfterImmTip =
+            fromMaybe (error "unreachable TODO") (AF.join currentPrefix candidateSuffix)
+
 
 selectForkSuffixes
-  :: (HasHeader header, HasHeader block,
-      HeaderHash header ~ HeaderHash block)
-  => AnchoredFragment block
+  :: HasHeader header
+  => AnchoredFragment header
   -> [(FetchDecision (AnchoredFragment header), peerinfo)]
   -> [(FetchDecision (ChainSuffix      header), peerinfo)]
 selectForkSuffixes current chains =
@@ -743,7 +748,7 @@ prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSiz
                 (equatingPair
                    -- compare on probability band first, then preferred chain
                    (==)
-                   (equateCandidateChains `on` getChainSuffix)
+                   (equateCandidateChains `on` getChainSuffixAfterImmutableTip)
                  `on`
                    (\(band, chain, _fragments) -> (band, chain)))))
   . sortBy  (descendingOrder
@@ -752,7 +757,7 @@ prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSiz
                   (comparingPair
                      -- compare on probability band first, then preferred chain
                      compare
-                     (compareCandidateChains `on` getChainSuffix)
+                     (compareCandidateChains `on` getChainSuffixAfterImmutableTip)
                    `on`
                       (\(band, chain, _fragments) -> (band, chain))))))
   . map annotateProbabilityBand
@@ -776,7 +781,7 @@ prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSiz
       | EQ <- compareCandidateChains chain1 chain2 = True
       | otherwise                                  = False
 
-    chainHeadPoint (_,ChainSuffix c,_) = AF.headPoint c
+    chainHeadPoint (_,ChainSuffix c _,_) = AF.headPoint c
 
 prioritisePeerChains FetchModeBulkSync salt compareCandidateChains blockFetchSize =
     map (\(decision, peer) ->

ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Genesis.hs

@@ -468,7 +468,7 @@ selectTheCandidate
                 -- maximumBy yields the last element in case of a tie while we
                 -- prefer the first one
                 chainSfx = fst $
-                  List.foldl1' (maxChainOn (getChainSuffix . fst)) inRace
+                  List.foldl1' (maxChainOn (getChainSuffixAfterImmutableTip . fst)) inRace
             pure $ Just (chainSfx, inRace)
 
 -- | Given _the_ candidate fragment to sync from, and a list of peers (with