Add no_livelock test.

Fix MockChain slot time.

ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs

@@ -250,7 +250,8 @@ withSlotTime slotDuration k = do
         go :: SlotNo -> m Void
         go next = do
           t <- getMonotonicTime
-          let delay = Time (slotDuration * fromIntegral (Block.unSlotNo next))
+          let delay = abs
+                    $ Time (slotDuration * fromIntegral (Block.unSlotNo next))
                       `diffTime` t
           threadDelay delay
           atomically $ writeTVar slotVar next

ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs

@@ -6,7 +6,7 @@
 module Test.Ouroboros.Network.Testnet (tests) where
 
 import           Control.Monad.IOSim
-import           Control.Monad.Class.MonadTime (Time (Time))
+import           Control.Monad.Class.MonadTime (Time (Time), diffTime, DiffTime)
 import           Control.Tracer (Tracer (Tracer), contramap, nullTracer)
 
 import           Data.Void (Void)
@@ -18,6 +18,7 @@ import           Data.Dynamic (Typeable)
 import           Data.Functor (void)
 import           Data.List (intercalate)
 import qualified Data.List.Trace as Trace
+import           Data.Time (secondsToDiffTime)
 
 import           System.Random (mkStdGen)
 import           GHC.Exception.Type (SomeException)
@@ -52,7 +53,7 @@ import           Test.Ouroboros.Network.Testnet.Simulation.Node
                      prop_diffusionScript_fixupCommands,
                      DiffusionSimulationTrace (..))
 import           Test.Ouroboros.Network.Diffusion.Node.NodeKernel
-import           Test.QuickCheck (Property, counterexample, conjoin)
+import           Test.QuickCheck (Property, counterexample, conjoin, property)
 import           Test.Tasty
 import           Test.Tasty.QuickCheck (testProperty)
 
@@ -64,6 +65,8 @@ tests =
                    prop_diffusionScript_fixupCommands
     , testProperty "diffusionScript command script valid"
                    prop_diffusionScript_commandScript_valid
+    , testProperty "diffusion no livelock"
+                   prop_diffusion_nolivelock
     , testProperty "diffusion target established local"
                    prop_diffusion_target_established_local
     , testProperty "diffusion target active below"
@@ -152,6 +155,72 @@ tracerDiffusionSimWithTimeName ntnAddr =
  . tracerWithTime
  $ dynamicTracer
 
+-- | A variant of
+-- 'Test.Ouroboros.Network.ConnectionHandler.Network.PeerSelection.prop_governor_nolivelock'
+-- but for running on Diffusion. This test doesn't check for events occuring at the same
+-- time but rather for events happening between an interval (usual 1s). This is because,
+-- since Diffusion is much more complex and can run more than 1 node in parallel, time
+-- might progress but very slowly almost like a livelock. We want to safeguard from such
+-- cases.
+--
+prop_diffusion_nolivelock :: AbsBearerInfo
+                         -> DiffusionScript
+                         -> Property
+prop_diffusion_nolivelock defaultBearerInfo diffScript@(DiffusionScript l) =
+    let sim :: forall s . IOSim s Void
+        sim = diffusionSimulation (toBearerInfo defaultBearerInfo)
+                                  diffScript
+                                  tracersExtraWithTimeName
+                                  tracerDiffusionSimWithTimeName
+     in check_governor_nolivelock (Time (10 * 60 * 60))
+                                  (secondsToDiffTime 0)
+                                  sim
+  where
+    check_governor_nolivelock :: Time
+                              -> DiffTime
+                              -> (forall s. IOSim s Void)
+                              -> Property
+    check_governor_nolivelock timeLimit dt sim =
+      let trace = Signal.eventsToList
+                . Signal.eventsFromListUpToTime timeLimit
+                . fmap (\(t, tid, tl, e) -> (t, (tid, tl, e)))
+                . traceEvents
+                $ runSimTrace sim
+
+          numberOfEvents = 1000 * max (length l) 1
+
+       in case tooManyEventsBeforeTimeAdvances numberOfEvents dt trace of
+            Nothing -> property True
+            Just es ->
+              counterexample
+                ("over " ++ show numberOfEvents ++ " events in "
+                ++ show dt ++ "\n" ++ "first " ++ show numberOfEvents
+                ++ " events: " ++ (unlines . map show . take numberOfEvents $ es))
+              $ property False
+
+    tooManyEventsBeforeTimeAdvances :: Int
+                                    -> DiffTime
+                                    -> [(Time, e)]
+                                    -> Maybe [(Time, e)]
+    tooManyEventsBeforeTimeAdvances _         _  []     = Nothing
+    tooManyEventsBeforeTimeAdvances threshold dt trace0 =
+        go (groupByTime dt trace0)
+      where
+        groupByTime :: DiffTime -> [(Time, e)] -> [[(Time, e)]]
+        groupByTime _ [] = []
+        groupByTime dtime trace@((t, _):_) =
+          let (tl, tr) = span (\(t', _) -> diffTime t' t <= dtime) trace
+           in tl : groupByTime dtime tr
+
+        go :: [[(Time, e)]] -> Maybe [(Time, e)]
+        go []    = Nothing
+        go (h:t)
+          | countdown threshold h = go t
+          | otherwise = Just h
+
+        countdown 0 (_ : _) = False
+        countdown _ []      = True
+        countdown n (_ : es)  = countdown (n-1) es
 
 -- | A variant of
 -- 'Test.Ouroboros.Network.PeerSelection.prop_governor_target_established_local'