From 7820864e779ace0813a224b7720ec84df1146d41 Mon Sep 17 00:00:00 2001
From: Armando Santos <armando@well-typed.com>
Date: Wed, 20 Apr 2022 10:53:51 +0100
Subject: [PATCH] Added cm_verify_transition_order

---
 .../test/Test/Ouroboros/Network/Testnet.hs    | 69 ++++++++++++++++++-
 .../Testnet/Simulation/ConnectionManager.hs   | 29 +++++++-
 2 files changed, 96 insertions(+), 2 deletions(-)

diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs
index 8a4574ecaee..9e97c2ce13b 100644
--- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs
+++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs
@@ -61,7 +61,8 @@ import           Test.Ouroboros.Network.Testnet.Simulation.ConnectionManager
                      AllProperty (..), classifyPrunings,
                      classifyNegotiatedDataFlow, classifyEffectiveDataFlow,
                      verifyAbstractTransition, classifyActivityType,
-                     classifyTermination, splitConns)
+                     classifyTermination, groupConns,
+                     verifyAbstractTransitionOrder)
 import           Test.Ouroboros.Network.Diffusion.Node.NodeKernel
 import           Test.QuickCheck (Property, counterexample, conjoin, classify, property)
 import           Test.Tasty
@@ -85,6 +86,8 @@ tests =
                    prop_diffusion_target_active_local_above
     , testProperty "diffusion connection manager valid transitions"
                    prop_diffusion_cm_valid_transitions
+    , testProperty "diffusion connection manager valid transition order"
+                   prop_diffusion_cm_valid_transition_order
     ]
   ]
 
@@ -792,6 +795,70 @@ prop_diffusion_cm_valid_transitions defaultBearerInfo diffScript =
         $ abstractTransitionEvents
 
 
+-- | A variant of ouroboros-network-framework
+-- 'Test.Ouroboros.Network.Server2.prop_connection_manager_valid_transition_order'
+-- but for running on Diffusion. This means it has to have in consideration the
+-- the logs for all nodes running will all appear in the trace and the test
+-- property should only be valid while a given node is up and running.
+--
+prop_diffusion_cm_valid_transition_order :: AbsBearerInfo
+                                         -> DiffusionScript
+                                         -> Property
+prop_diffusion_cm_valid_transition_order defaultBearerInfo diffScript =
+    let sim :: forall s . IOSim s Void
+        sim = diffusionSimulation (toBearerInfo defaultBearerInfo)
+                                  diffScript
+                                  tracersExtraWithTimeName
+                                  tracerDiffusionSimWithTimeName
+
+        events :: [Trace () (WithName NtNAddr (WithTime DiffusionTestTrace))]
+        events = fmap (Trace.fromList ())
+               . Trace.toList
+               . splitWithNameTrace
+               . Trace.fromList ()
+               . fmap snd
+               . Signal.eventsToList
+               . Signal.eventsFromListUpToTime (Time (10 * 60 * 60))
+               . Trace.toList
+               . fmap (\(WithTime t (WithName name b))
+                       -> (t, WithName name (WithTime t b)))
+               . withTimeNameTraceEvents
+                  @DiffusionTestTrace
+                  @NtNAddr
+               . Trace.fromList (MainReturn (Time 0) () [])
+               . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te)
+               . take 1000000
+               . traceEvents
+               $ runSimTrace sim
+
+     in conjoin
+      $ (\ev ->
+        let evsList = Trace.toList ev
+            lastTime = (\(WithName _ (WithTime t _)) -> t)
+                     . last
+                     $ evsList
+         in classifySimulatedTime lastTime
+          $ classifyNumberOfEvents (length evsList)
+          $ verify_cm_valid_transition_order
+          $ (\(WithName _ (WithTime _ b)) -> b)
+          <$> ev
+        )
+      <$> events
+  where
+    verify_cm_valid_transition_order :: Trace () DiffusionTestTrace -> Property
+    verify_cm_valid_transition_order events =
+      let abstractTransitionEvents :: Trace () (AbstractTransitionTrace NtNAddr)
+          abstractTransitionEvents =
+            selectDiffusionConnectionManagerTransitionEvents events
+
+       in getAllProperty
+         . bifoldMap
+            (const mempty)
+            verifyAbstractTransitionOrder
+         . fmap (map ttTransition)
+         . groupConns id
+         $ abstractTransitionEvents
+
 -- Utils
 --
 
diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/ConnectionManager.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/ConnectionManager.hs
index 18b7b2aeb75..1df0fae46e7 100644
--- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/ConnectionManager.hs
+++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/ConnectionManager.hs
@@ -22,7 +22,7 @@ import           Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace)
 
 import           Test.QuickCheck
                      (Property, (.&&.), Testable (property), label, tabulate,
-                     cover)
+                     cover, counterexample)
 
 -- | Groups 'AbstractTransitionTrace' to the same peerAddr. Since in Diffusion tests
 -- we truncate the trace we can no longer use splitConns under the assumption that all
@@ -157,6 +157,33 @@ verifyAbstractTransition Transition { fromState, toState } =
 
       _ -> False
 
+-- Assuming all transitions in the transition list are valid, we only need to
+-- look at the 'toState' of the current transition and the 'fromState' of the
+-- next transition.
+verifyAbstractTransitionOrder :: [AbstractTransition]
+                              -> AllProperty
+verifyAbstractTransitionOrder [] = mempty
+verifyAbstractTransitionOrder (h:t) = go t h
+  where
+    go :: [AbstractTransition] -> AbstractTransition -> AllProperty
+    -- All transitions must end in the 'UnknownConnectionSt', however since this
+    -- going to be used by diffusion test where the trace to be evaluated is
+    -- possibly truncated we can not be certain that the last transition is
+    -- going to end in 'UnknownConnectionSt'.
+    go [] (Transition _ _)          =
+      AllProperty (property True)
+    -- All transitions have to be in a correct order, which means that the
+    -- current state we are looking at (current toState) needs to be equal to
+    -- the next 'fromState', in order for the transition chain to be correct.
+    go (next@(Transition nextFromState _) : ts)
+        curr@(Transition _ currToState) =
+         AllProperty
+           (counterexample
+              ("\nUnexpected transition order!\nWent from: "
+              ++ show curr ++ "\nto: " ++ show next)
+              (property (currToState == nextFromState)))
+         <> go ts next
+
 
 --
 -- | Test property together with classification.