diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index eaa219320e1..142da97135e 100644 --- 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 index 7182255217a..b5e3718aef4 100644 --- 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 +