test-consensus: add infra-slot delays

We add random network latencies but crucially also ensure that each test slot
cannot end until all network channels have been empty for some duration that
reasonable dwarfs any computational delays. The goal is for the node network to
always reach a steady state before the next slot begins, despite random network
latencies.

ouroboros-consensus/ouroboros-consensus.cabal

@@ -317,6 +317,7 @@ test-suite test-consensus
                     random,
                     reflection,
                     serialise,
+                    splitmix,
                     tasty,
                     tasty-hunit,
                     tasty-quickcheck,

ouroboros-consensus/test-consensus/Test/Dynamic/General.hs

@@ -9,7 +9,10 @@ module Test.Dynamic.General (
   , runTestNetwork
     -- * TestConfig
   , TestConfig (..)
+  , genLatencySeed
   , genTestConfig
+  , noLatencySeed
+  , shrinkLatencySeed
   , shrinkTestConfig
     -- * Re-exports
   , TestOutput (..)
@@ -21,6 +24,7 @@ import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Word (Word64)
 import           GHC.Stack (HasCallStack)
+import qualified System.Random.SplitMix as SM
 import           Test.QuickCheck
 
 import           Control.Monad.IOSim (runSimOrThrow)
@@ -63,46 +67,68 @@ data TestConfig = TestConfig
   , numSlots     :: !NumSlots
   , nodeJoinPlan :: !NodeJoinPlan
   , nodeTopology :: !NodeTopology
+  , latencySeed  :: !(LatencyInjection SM.SMGen)
   }
   deriving (Show)
 
+noLatencySeed :: LatencyInjection a
+noLatencySeed = DoNotInjectLatencies
+
+genLatencySeed :: Gen (LatencyInjection SM.SMGen)
+genLatencySeed = (InjectLatencies . SM.mkSMGen) <$> arbitrary
+
+shrinkLatencySeed :: LatencyInjection SM.SMGen -> [LatencyInjection SM.SMGen]
+shrinkLatencySeed li =
+    takeWhile (diffCtor li) [DoNotInjectLatencies, InjectTrivialLatencies]
+  where
+    diffCtor DoNotInjectLatencies   DoNotInjectLatencies   = False
+    diffCtor InjectTrivialLatencies InjectTrivialLatencies = False
+    diffCtor InjectLatencies{}      InjectLatencies{}      = False
+    diffCtor _                      _                      = True
+
 genTestConfig :: NumCoreNodes -> NumSlots -> Gen TestConfig
 genTestConfig numCoreNodes numSlots = do
     nodeJoinPlan <- genNodeJoinPlan numCoreNodes numSlots
     nodeTopology <- genNodeTopology numCoreNodes
-    pure TestConfig{numCoreNodes, numSlots, nodeJoinPlan, nodeTopology}
+    latencySeed <- genLatencySeed
+    pure TestConfig
+      { numCoreNodes, numSlots, nodeJoinPlan, nodeTopology, latencySeed }
+
+idAnd :: forall a. (a -> [a]) -> a -> [a]
+idAnd f x = x : f x
 
 -- | Shrink without changing the number of nodes or slots
 shrinkTestConfig :: TestConfig -> [TestConfig]
-shrinkTestConfig testConfig@TestConfig{nodeJoinPlan, nodeTopology} =
+shrinkTestConfig
+  testConfig@TestConfig{nodeJoinPlan, nodeTopology, latencySeed} =
     tail $ -- drop the identity output
-    [ testConfig{nodeJoinPlan = p', nodeTopology = top'}
-    | p' <- nodeJoinPlan : shrinkNodeJoinPlan nodeJoinPlan
-    , top' <- nodeTopology : shrinkNodeTopology nodeTopology
+    [ testConfig{nodeJoinPlan = p', nodeTopology = top', latencySeed = seed'}
+    | p'    <- idAnd shrinkNodeJoinPlan nodeJoinPlan
+    , top'  <- idAnd shrinkNodeTopology nodeTopology
+    , seed' <- idAnd shrinkLatencySeed latencySeed
     ]
 
 -- | Shrink, including the number of nodes and slots
 shrinkTestConfigFreely :: TestConfig -> [TestConfig]
 shrinkTestConfigFreely
-  TestConfig{numCoreNodes, numSlots, nodeJoinPlan, nodeTopology} =
+  TestConfig{numCoreNodes, numSlots, nodeJoinPlan, nodeTopology, latencySeed} =
     tail $   -- drop the identity result
     [ TestConfig
         { numCoreNodes = n'
         , numSlots = t'
         , nodeJoinPlan = p'
         , nodeTopology = top'
+        , latencySeed = seed'
         }
-    | n' <- idAnd shrink numCoreNodes
-    , t' <- idAnd shrink numSlots
-    , let adjustedP = adjustedNodeJoinPlan n' t'
+    | n'    <- idAnd shrink numCoreNodes
+    , t'    <- idAnd shrink numSlots
+    , let adjustedP   = adjustedNodeJoinPlan n' t'
     , let adjustedTop = adjustedNodeTopology n'
-    , p' <- idAnd shrinkNodeJoinPlan adjustedP
-    , top' <- idAnd shrinkNodeTopology adjustedTop
+    , p'    <- idAnd shrinkNodeJoinPlan adjustedP
+    , top'  <- idAnd shrinkNodeTopology adjustedTop
+    , seed' <- idAnd shrinkLatencySeed latencySeed
     ]
   where
-    idAnd :: forall a. (a -> [a]) -> a -> [a]
-    idAnd f x = x : f x
-
     adjustedNodeJoinPlan (NumCoreNodes n') (NumSlots t') =
         NodeJoinPlan $
         -- scale by t' / t
@@ -143,22 +169,36 @@ runTestNetwork ::
   -> Seed
   -> TestOutput blk
 runTestNetwork pInfo
-  TestConfig{numCoreNodes, numSlots, nodeJoinPlan, nodeTopology}
+  TestConfig{numCoreNodes, numSlots, nodeJoinPlan, nodeTopology, latencySeed}
   seed = runSimOrThrow $ do
     registry  <- unsafeNewRegistry
-    testBtime <- newTestBlockchainTime registry numSlots slotLen
+
+    -- the latest slot that is ready to start
+    latestReadySlot <- uncheckedNewTVarM (SlotNo 0)
+    -- a slot cannot end before a later slot is ready to start
+    let waitOn s = atomically $ do
+          x <- readTVar latestReadySlot
+          check (s < x)
+    testBtime <- newTestGuardedBlockchainTime registry numSlots slotLen waitOn
+
     runNodeNetwork
       registry
+      quiescenceThreshold
+      latestReadySlot
       testBtime
       numCoreNodes
       nodeJoinPlan
       nodeTopology
       pInfo
+      latencySeed
       (seedToChaCha seed)
       slotLen
   where
-    slotLen :: DiffTime
-    slotLen = 100000
+    slotLen             = 100000 :: DiffTime
+
+    -- a slot cannot advance until all of the ChainSync and BlockFetch pipes
+    -- have been empty for at least this duration
+    quiescenceThreshold = 5000 :: DiffTime
 
 {-------------------------------------------------------------------------------
   Test properties

ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs

@@ -51,13 +51,21 @@ tests = testGroup "Dynamic chain generation"
             (genNodeTopology numCoreNodes)
             shrinkNodeTopology $
         \nodeTopology ->
+        forAllShrink genLatencySeed shrinkLatencySeed $
+        \latencySeed ->
         forAllShrink
             (genLeaderSchedule k numSlots numCoreNodes nodeJoinPlan)
             (shrinkLeaderSchedule numSlots) $
         \schedule ->
             prop_simple_leader_schedule_convergence
                 params
-                TestConfig{numCoreNodes, numSlots, nodeJoinPlan, nodeTopology}
+                TestConfig
+                  { numCoreNodes
+                  , numSlots
+                  , nodeJoinPlan
+                  , nodeTopology
+                  , latencySeed
+                  }
                 schedule seed
 
 prop_simple_leader_schedule_convergence :: PraosParams