Added IG Valid Transition order test

IntersectMBO · Apr 11, 2022 · 2ed7e98 · 2ed7e98
1 parent acadc45
commit 2ed7e98
Show file tree

Hide file tree

Showing 2 changed files with 98 additions and 4 deletions.
diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs
@@ -36,7 +36,8 @@ import           Ouroboros.Network.Testing.Data.Signal
 import           Ouroboros.Network.PeerSelection.RootPeersDNS
                       (TraceLocalRootPeers, TracePublicRootPeers)
 import           Ouroboros.Network.PeerSelection.Types (PeerStatus(..))
-import           Ouroboros.Network.Diffusion.P2P (TracersExtra(..), RemoteTransitionTrace)
+import           Ouroboros.Network.Diffusion.P2P
+                      (TracersExtra(..), RemoteTransitionTrace)
 import           Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace)
 import           Ouroboros.Network.ConnectionManager.Types
 import qualified Ouroboros.Network.Testing.Data.Signal as Signal
@@ -63,7 +64,8 @@ import           Test.Ouroboros.Network.Testnet.Simulation.ConnectionManager
                      classifyTermination, groupConns,
                      verifyAbstractTransitionOrder)
 import           Test.Ouroboros.Network.Testnet.Simulation.InboundGovernor
-                     (verifyRemoteTransition)
+                     (verifyRemoteTransition, splitRemoteConns,
+                     verifyRemoteTransitionOrder)
 import           Test.Ouroboros.Network.Diffusion.Node.NodeKernel
 import           Test.QuickCheck (Property, counterexample, conjoin, property)
 import           Test.Tasty
@@ -91,6 +93,8 @@ tests =
                    prop_diffusion_cm_valid_transition_order
     , testProperty "diffusion inbound governor valid transitions"
                    prop_diffusion_ig_valid_transitions
+    , testProperty "diffusion inbound governor valid transition order"
+                   prop_diffusion_ig_valid_transition_order
     ]
   ]
 
@@ -864,6 +868,58 @@ prop_diffusion_ig_valid_transitions defaultBearerInfo diffScript =
             )
          $ remoteTransitionTraceEvents
 
+-- | A variant of ouroboros-network-framework
+-- 'Test.Ouroboros.Network.Server2.prop_inbound_governor_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_ig_valid_transition_order :: AbsBearerInfo
+                                         -> DiffusionScript
+                                         -> Property
+prop_diffusion_ig_valid_transition_order defaultBearerInfo diffScript =
+    let sim :: forall s . IOSim s Void
+        sim = diffusionSimulation (toBearerInfo defaultBearerInfo)
+                                  diffScript
+                                  tracersExtraWithTimeName
+                                  tracerDiffusionSimWithTimeName
+
+        events :: [Trace () DiffusionTestTrace]
+        events = fmap ( Trace.fromList ()
+                      . fmap (\(WithName _ (WithTime _ b)) -> b))
+               . 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
+               $ runSimTrace sim
+
+     in conjoin
+      $ verify_cm_valid_transition_order
+      <$> events
+
+  where
+    verify_cm_valid_transition_order :: Trace () DiffusionTestTrace -> Property
+    verify_cm_valid_transition_order events =
+
+      let remoteTransitionTraceEvents :: Trace () (RemoteTransitionTrace NtNAddr)
+          remoteTransitionTraceEvents =
+            selectDiffusionInboundGovernorTransitionEvents events
+
+      in getAllProperty
+        . bifoldMap
+           (const mempty)
+           verifyRemoteTransitionOrder
+        . splitRemoteConns
+        $ remoteTransitionTraceEvents
+
 -- Utils
 --
 

diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/InboundGovernor.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/InboundGovernor.hs
@@ -7,10 +7,17 @@
 -- and adapts them in order to be used in Diffusion Tests.
 module Test.Ouroboros.Network.Testnet.Simulation.InboundGovernor where
 
+
+import           Data.Bitraversable (bimapAccumL)
+import           Data.List.Trace (Trace)
+import qualified Data.List.Trace as Trace
+import qualified Data.Map as Map
+import           Data.Maybe (fromJust, isJust)
+
 import           Ouroboros.Network.ConnectionManager.Types
-                     (Transition' (..))
+                     (Transition' (..), TransitionTrace' (..))
 import           Ouroboros.Network.InboundGovernor
-                     (RemoteTransition, RemoteSt (..))
+                     (RemoteTransition, RemoteSt (..), RemoteTransitionTrace)
 
 import           Test.QuickCheck
                      (Testable (property), counterexample)
@@ -110,3 +117,34 @@ verifyRemoteTransitionOrder (h:t) = go t h
               ++ show curr ++ "\nto: " ++ show next)
               (property (currToState == nextFromState)))
          <> go ts next
+
+
+splitRemoteConns :: Ord addr
+                 => Trace r (RemoteTransitionTrace addr)
+                 -> Trace r [RemoteTransition]
+splitRemoteConns =
+    fmap fromJust
+  . Trace.filter isJust
+  -- there might be some connections in the state, push them onto the 'Trace'
+  . (\(s, o) -> foldr (\a as -> Trace.Cons (Just a) as) o (Map.elems s))
+  . bimapAccumL
+      ( \ s a -> ( s, a))
+      ( \ s TransitionTrace { ttPeerAddr, ttTransition } ->
+          case ttTransition of
+            Transition _ Nothing ->
+              case ttPeerAddr `Map.lookup` s of
+                Nothing  -> ( Map.insert ttPeerAddr [ttTransition] s
+                            , Nothing
+                            )
+                Just trs -> ( Map.delete ttPeerAddr s
+                            , Just (reverse $ ttTransition : trs)
+                            )
+            _ ->            ( Map.alter ( \ case
+                                              Nothing -> Just [ttTransition]
+                                              Just as -> Just (ttTransition : as)
+                                        ) ttPeerAddr s
+                            , Nothing
+                            )
+      )
+      Map.empty
+