Specify the order in which to start the peers

Author: Niols

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs

@@ -499,7 +499,8 @@ prop_densityDisconnectTriggersChainSel =
             (AF.Empty _)       -> Origin
             (_ AF.:> tipBlock) -> At tipBlock
           advTip = getOnlyBranchTip tree
-       in mkPointSchedule $ peers'
+       in PointSchedule {
+            psSchedule = peers'
             -- Eagerly serve the honest tree, but after the adversary has
             -- advertised its chain up to the intersection.
             [[(Time 0, scheduleTipPoint trunkTip),
@@ -514,4 +515,7 @@ prop_densityDisconnectTriggersChainSel =
               (Time 0, ScheduleBlockPoint intersect),
               (Time 1, scheduleHeaderPoint advTip),
               (Time 1, scheduleBlockPoint advTip)
-            ]]
+            ]],
+            psStartOrder = [],
+            psMinEndTime = Time 0
+          }

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE.hs

@@ -115,4 +115,4 @@ prop_adversaryHitsTimeouts timeoutsEnabled =
             ]
           -- We want to wait more than the short wait timeout
           psMinEndTime = Time 11
-       in PointSchedule {psSchedule, psMinEndTime}
+       in PointSchedule {psSchedule, psStartOrder = [], psMinEndTime}

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoP.hs

@@ -79,6 +79,7 @@ prop_wait mustTimeout =
       let offset :: DiffTime = if mustTimeout then 1 else -1
        in PointSchedule
             { psSchedule = peersOnlyHonest [(Time 0, scheduleTipPoint tipBlock)]
+            , psStartOrder = []
             , psMinEndTime = Time $ timeout + offset
             }
 
@@ -108,6 +109,7 @@ prop_waitBehindForecastHorizon =
             [ (Time 0, scheduleTipPoint tipBlock)
             , (Time 0, scheduleHeaderPoint tipBlock)
             ]
+        , psStartOrder = []
         , psMinEndTime = Time 11
         }
 
@@ -166,13 +168,18 @@ prop_serve mustTimeout =
     makeSchedule :: (HasHeader blk) => AnchoredFragment blk -> PointSchedule blk
     makeSchedule (AF.Empty _) = error "fragment must have at least one block"
     makeSchedule fragment@(_ AF.:> tipBlock) =
-      mkPointSchedule $ peersOnlyHonest $
+      PointSchedule {
+        psSchedule =
+        peersOnlyHonest $
         (Time 0, scheduleTipPoint tipBlock)
           : ( flip concatMap (zip [1 ..] (AF.toOldestFirst fragment)) $ \(i, block) ->
                 [ (Time (secondsRationalToDiffTime (i * timeBetweenBlocks)), scheduleHeaderPoint block),
                   (Time (secondsRationalToDiffTime (i * timeBetweenBlocks)), scheduleBlockPoint block)
                 ]
-            )
+            ),
+        psStartOrder = [],
+        psMinEndTime = Time 0
+      }
 
 -- NOTE: Same as 'LoE.prop_adversaryHitsTimeouts' with LoP instead of timeouts.
 prop_delayAttack :: Bool -> Property
@@ -249,4 +256,4 @@ prop_delayAttack lopEnabled =
             ]
           -- Wait for LoP bucket to empty
           psMinEndTime = Time 11
-       in PointSchedule {psSchedule, psMinEndTime}
+       in PointSchedule {psSchedule, psStartOrder = [], psMinEndTime}

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs

@@ -288,6 +288,7 @@ prop_leashingAttackTimeLimited =
           advs = fmap (takePointsUntil timeLimit) advs0
       pure $ PointSchedule
         { psSchedule = Peers honests advs
+        , psStartOrder = []
         , psMinEndTime = timeLimit
         }
 

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs

@@ -17,6 +17,7 @@ import           Control.ResourceRegistry
 import           Control.Tracer (Tracer (..), nullTracer, traceWith)
 import           Data.Coerce (coerce)
 import           Data.Foldable (for_)
+import           Data.List (sort)
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -340,8 +341,15 @@ startNode schedulerConfig genesisTest interval = do
       getCandidates = viewChainSyncState (cschcMap handles) CSClient.csCandidate
   fetchClientRegistry <- newFetchClientRegistry
   let chainDbView = CSClient.defaultChainDbView lnChainDb
-      activePeers = Map.restrictKeys (psrPeers lrPeerSim) (lirActive liveResult)
-  for_ activePeers $ \PeerResources {prShared, prChainSync, prBlockFetch} -> do
+      activePeers = Map.toList $ Map.restrictKeys (psrPeers lrPeerSim) (lirActive liveResult)
+      peersStartOrder = psStartOrder ++ sort [pid | (pid, _) <- activePeers, pid `notElem` psStartOrder]
+      activePeersOrdered = [
+          peerResources
+          | pid <- peersStartOrder
+          , (pid', peerResources) <- activePeers
+          , pid == pid'
+          ]
+  for_ activePeersOrdered $ \PeerResources {prShared, prChainSync, prBlockFetch} -> do
     let pid = srPeerId prShared
     forkLinkedThread lrRegistry ("Peer overview " ++ show pid) $
       -- The peerRegistry helps ensuring that if any thread fails, then
@@ -405,6 +413,7 @@ startNode schedulerConfig genesisTest interval = do
       , gtBlockFetchTimeouts
       , gtLoPBucketParams = LoPBucketParams { lbpCapacity, lbpRate }
       , gtCSJParams = CSJParams { csjpJumpSize }
+      , gtSchedule = PointSchedule {psStartOrder}
       } = genesisTest
 
     StateViewTracers{svtTraceTracer} = lnStateViewTracers

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs

@@ -72,4 +72,4 @@ prop_chainSyncKillsBlockFetch = do
               (Time 0, scheduleHeaderPoint firstBlock)
             ]
           psMinEndTime = Time $ timeout + 1
-       in PointSchedule {psSchedule, psMinEndTime}
+       in PointSchedule {psSchedule, psStartOrder = [], psMinEndTime}

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Rollback.hs

@@ -95,7 +95,11 @@ rollbackSchedule n blockTree =
           , banalSchedulePoints trunkSuffix
           , banalSchedulePoints (btbSuffix branch)
           ]
-    in mkPointSchedule $ peersOnlyHonest $ zip (map (Time . (/30)) [0..]) schedulePoints
+    in PointSchedule {
+         psSchedule = peersOnlyHonest $ zip (map (Time . (/30)) [0..]) schedulePoints,
+         psStartOrder = [],
+         psMinEndTime = Time 0
+       }
   where
     banalSchedulePoints :: AnchoredFragment blk -> [SchedulePoint blk]
     banalSchedulePoints = concatMap banalSchedulePoints' . toOldestFirst

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs

@@ -70,4 +70,4 @@ prop_timeouts mustTimeout = do
             ]
           -- This keeps the test running long enough to pass the timeout by 'offset'.
           psMinEndTime = Time $ timeout + offset
-       in PointSchedule {psSchedule, psMinEndTime}
+       in PointSchedule {psSchedule, psStartOrder = [], psMinEndTime}

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs

@@ -37,7 +37,6 @@ module Test.Consensus.PointSchedule (
   , ensureScheduleDuration
   , genesisNodeState
   , longRangeAttack
-  , mkPointSchedule
   , peerSchedulesBlocks
   , peerStates
   , peersStates
@@ -55,7 +54,6 @@ import           Control.Monad.Class.MonadTime.SI (Time (Time), addTime,
 import           Control.Monad.ST (ST)
 import           Data.Functor (($>))
 import           Data.List (mapAccumL, partition, scanl')
-import qualified Data.Map.Strict as Map
 import           Data.Maybe (catMaybes, fromMaybe, mapMaybe)
 import           Data.Time (DiffTime)
 import           Data.Word (Word64)
@@ -77,8 +75,8 @@ import           Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..),
 import           Test.Consensus.PeerSimulator.StateView (StateView)
 import           Test.Consensus.PointSchedule.NodeState (NodeState (..),
                      genesisNodeState)
-import           Test.Consensus.PointSchedule.Peers (Peer (..), Peers (..),
-                     peers', peersList)
+import           Test.Consensus.PointSchedule.Peers (Peer (..), PeerId,
+                     Peers (..), getPeerIds, peers', peersList)
 import           Test.Consensus.PointSchedule.SinglePeer
                      (IsTrunk (IsBranch, IsTrunk), PeerScheduleParams (..),
                      SchedulePoint (..), defaultPeerScheduleParams, mergeOn,
@@ -97,21 +95,24 @@ prettyPointSchedule ::
   (CondenseList (NodeState blk)) =>
   PointSchedule blk ->
   [String]
-prettyPointSchedule peers =
-  [ "honest peers: " ++ show (Map.size (honestPeers $ psSchedule peers))
-  , "adversaries: " ++ show (Map.size (adversarialPeers $ psSchedule peers))
-  , "minimal duration: " ++ show (psMinEndTime peers)
-  ] ++
-  zipWith3
-    (\number time peerState ->
-      number ++ ": " ++ peerState ++ " @ " ++ time
-    )
-    (condenseListWithPadding PadLeft $ fst <$> numberedPeersStates)
-    (showDT . fst . snd <$> numberedPeersStates)
-    (condenseList $ (snd . snd) <$> numberedPeersStates)
+prettyPointSchedule ps@PointSchedule {psStartOrder, psMinEndTime} =
+  []
+    ++ [ "psSchedule ="
+       ]
+    ++ ( zipWith3
+           ( \number time peerState ->
+               "  " ++ number ++ ": " ++ peerState ++ " @ " ++ time
+           )
+           (condenseListWithPadding PadLeft $ fst <$> numberedPeersStates)
+           (showDT . fst . snd <$> numberedPeersStates)
+           (condenseList $ (snd . snd) <$> numberedPeersStates)
+       )
+    ++ [ "psStartOrder = " ++ show psStartOrder,
+         "psMinEndTime = " ++ show psMinEndTime
+       ]
   where
     numberedPeersStates :: [(Int, (Time, Peer (NodeState blk)))]
-    numberedPeersStates = zip [0..] (peersStates peers)
+    numberedPeersStates = zip [0 ..] (peersStates ps)
 
     showDT :: Time -> String
     showDT (Time dt) = printf "%.6f" (realToFrac dt :: Double)
@@ -177,15 +178,17 @@ peerScheduleBlocks = mapMaybe (withOriginToMaybe . schedulePointToBlock . snd)
 data PointSchedule blk = PointSchedule {
     -- | The actual point schedule
     psSchedule   :: Peers (PeerSchedule blk),
+    -- | The order in which the peers start and connect to the node under test.
+    -- The peers that are absent from 'psSchedule' are ignored; the peers from
+    -- 'psSchedule' that are absent of 'psStartOrder' are started in the end in
+    -- the order of 'PeerId'.
+    psStartOrder :: [PeerId],
     -- | Minimum duration for the simulation of this point schedule.
     -- If no point in the schedule is larger than 'psMinEndTime',
     -- the simulation will still run until this time is reached.
     psMinEndTime :: Time
   }
 
-mkPointSchedule :: Peers (PeerSchedule blk) -> PointSchedule blk
-mkPointSchedule sch = PointSchedule sch $ Time 0
-
 -- | List of all blocks appearing in the schedules.
 peerSchedulesBlocks :: Peers (PeerSchedule blk) -> [blk]
 peerSchedulesBlocks = concatMap (peerScheduleBlocks . value) . peersList
@@ -208,7 +211,11 @@ longRangeAttack ::
 longRangeAttack BlockTree {btTrunk, btBranches = [branch]} g = do
   honest <- peerScheduleFromTipPoints g honParams [(IsTrunk, [AF.length btTrunk - 1])] btTrunk []
   adv <- peerScheduleFromTipPoints g advParams [(IsBranch, [AF.length (btbFull branch) - 1])] btTrunk [btbFull branch]
-  pure $ mkPointSchedule $ peers' [honest] [adv]
+  pure $ PointSchedule {
+    psSchedule = peers' [honest] [adv],
+    psStartOrder = [],
+    psMinEndTime = Time 0
+    }
   where
     honParams = defaultPeerScheduleParams {pspHeaderDelayInterval = (0.3, 0.4)}
     advParams = defaultPeerScheduleParams {pspTipDelayInterval = (0, 0.1)}
@@ -240,6 +247,7 @@ uniformPoints PointsGeneratorParams {pgpExtraHonestPeers, pgpDowntime} = case pg
 -- Include rollbacks in a percentage of adversaries, in which case that peer uses two branchs.
 --
 uniformPointsWithExtraHonestPeers ::
+  forall g m blk.
   (StatefulGen g m, AF.HasHeader blk) =>
   Int ->
   BlockTree blk ->
@@ -254,7 +262,9 @@ uniformPointsWithExtraHonestPeers
   honests <- replicateM (extraHonestPeers + 1) $
     mkSchedule [(IsTrunk, [honestTip0 .. AF.length btTrunk - 1])] []
   advs <- takeBranches btBranches
-  pure $ mkPointSchedule $ peers' honests advs
+  let psSchedule = peers' honests advs
+  psStartOrder <- shuffle (getPeerIds psSchedule)
+  pure $ PointSchedule {psSchedule, psStartOrder, psMinEndTime = Time 0}
   where
     takeBranches = \case
         [] -> pure []
@@ -305,6 +315,15 @@ uniformPointsWithExtraHonestPeers
 
     rollbackProb = 0.2
 
+    -- Inefficient implementation, but sufficient for small lists.
+    shuffle :: [a] -> m [a]
+    shuffle [] = pure []
+    shuffle xs = do
+      i <- Random.uniformRM (0, length xs - 1) g
+      let x = xs !! i
+          xs' = take i xs ++ drop (i+1) xs
+      (x :) <$> shuffle xs'
+
 minusClamp :: (Ord a, Num a) => a -> a -> a
 minusClamp a b | a <= b = 0
                | otherwise = a - b
@@ -361,6 +380,7 @@ syncTips honests advs =
 --
 -- Includes rollbacks in some schedules.
 uniformPointsWithExtraHonestPeersAndDowntime ::
+  forall g m blk.
   (StatefulGen g m, AF.HasHeader blk) =>
   Int ->
   SecurityParam ->
@@ -383,7 +403,9 @@ uniformPointsWithExtraHonestPeersAndDowntime
     mkSchedule [(IsTrunk, [honestTip0, minusClamp (AF.length btTrunk) 1])] []
   advs <- takeBranches pauseSlot btBranches
   let (honests', advs') = syncTips honests advs
-  pure $ mkPointSchedule $ peers' honests' advs'
+      psSchedule = peers' honests' advs'
+  psStartOrder <- shuffle $ getPeerIds psSchedule
+  pure $ PointSchedule {psSchedule, psStartOrder, psMinEndTime = Time 0}
   where
     takeBranches pause = \case
         [] -> pure []
@@ -438,6 +460,15 @@ uniformPointsWithExtraHonestPeersAndDowntime
 
     rollbackProb = 0.2
 
+    -- Inefficient implementation, but sufficient for small lists.
+    shuffle :: [a] -> m [a]
+    shuffle [] = pure []
+    shuffle xs = do
+      i <- Random.uniformRM (0, length xs - 1) g
+      let x = xs !! i
+          xs' = take i xs ++ drop (i+1) xs
+      (x :) <$> shuffle xs'
+
 newtype ForecastRange = ForecastRange { unForecastRange :: Word64 }
   deriving (Show)
 
@@ -545,9 +576,10 @@ stToGen gen = do
   pure (runSTGen_ seed gen)
 
 ensureScheduleDuration :: GenesisTest blk a -> PointSchedule blk -> PointSchedule blk
-ensureScheduleDuration gt PointSchedule{psSchedule, psMinEndTime} =
+ensureScheduleDuration gt PointSchedule{psSchedule, psStartOrder, psMinEndTime} =
     PointSchedule
       { psSchedule
+      , psStartOrder
       , psMinEndTime = max psMinEndTime (Time endingDelay)
       }
   where

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/Shrinking.hs

@@ -41,7 +41,7 @@ shrinkPeerSchedules ::
   StateView TestBlock ->
   [GenesisTestFull TestBlock]
 shrinkPeerSchedules genesisTest@GenesisTest{gtBlockTree, gtSchedule} _stateView =
-  let PointSchedule {psSchedule} = gtSchedule
+  let PointSchedule {psSchedule, psStartOrder} = gtSchedule
       simulationDuration = duration gtSchedule
       trimmedBlockTree sch = trimBlockTree' sch gtBlockTree
       shrunkAdversarialPeers =
@@ -50,6 +50,7 @@ shrinkPeerSchedules genesisTest@GenesisTest{gtBlockTree, gtSchedule} _stateView
             genesisTest
               { gtSchedule = PointSchedule
                   { psSchedule = shrunkSchedule
+                  , psStartOrder
                   , psMinEndTime = simulationDuration
                   }
               , gtBlockTree = trimmedBlockTree shrunkSchedule
@@ -61,6 +62,7 @@ shrinkPeerSchedules genesisTest@GenesisTest{gtBlockTree, gtSchedule} _stateView
         <&> \shrunkSchedule -> genesisTest
           { gtSchedule = PointSchedule
             { psSchedule = shrunkSchedule
+            , psStartOrder
             , psMinEndTime = simulationDuration
             }
           }
@@ -81,6 +83,7 @@ shrinkByRemovingAdversaries genesisTest@GenesisTest{gtSchedule, gtBlockTree} _st
      in genesisTest
       { gtSchedule = PointSchedule
         { psSchedule = shrunkSchedule
+        , psStartOrder = psStartOrder gtSchedule
         , psMinEndTime = simulationDuration
         }
       , gtBlockTree = trimmedBlockTree