Rename BlockFetch tests that only test BulkSync mode

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

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

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/BlockFetch.hs

@@ -64,11 +64,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
@@ -105,8 +105,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)) $
@@ -160,10 +160,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)) $

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs

@@ -295,7 +295,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

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.
 --
@@ -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,16 +295,17 @@ fetchDecisionsBulkSyncM
                          }
             _ -> pure peersOrder
 
-      setCurrentPeer :: peer -> PeersOrder peer -> PeersOrder peer
-      setCurrentPeer peer peersOrder =
-        case extract ((peer ==)) (peersOrderAll peersOrder) of
-          Just (p, xs) ->
+      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
               { 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 +496,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.