diff --git a/ouroboros-network-framework/testlib/TestLib/ConnectionManager.hs b/ouroboros-network-framework/testlib/TestLib/ConnectionManager.hs index c371b5fab22..dafb3d92e8d 100644 --- a/ouroboros-network-framework/testlib/TestLib/ConnectionManager.hs +++ b/ouroboros-network-framework/testlib/TestLib/ConnectionManager.hs @@ -4,6 +4,7 @@ module TestLib.ConnectionManager where import Prelude hiding (read) +import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) import Ouroboros.Network.ConnectionManager.Types import Test.QuickCheck (counterexample, property) @@ -252,3 +253,54 @@ allValidTransitionsNames = abstractStateIsFinalTransition :: Transition' AbstractState -> Bool abstractStateIsFinalTransition (Transition _ UnknownConnectionSt) = True abstractStateIsFinalTransition _ = False + + +connectionManagerTraceMap + :: ConnectionManagerTrace + ntnAddr + (ConnectionHandlerTrace ntnVersion ntnVersionData) + -> String +connectionManagerTraceMap (TrIncludeConnection p _) = + "TrIncludeConnection " ++ show p +connectionManagerTraceMap (TrUnregisterConnection p _) = + "TrUnregisterConnection " ++ show p +connectionManagerTraceMap (TrConnect _ _) = + "TrConnect" +connectionManagerTraceMap (TrConnectError _ _ _) = + "TrConnectError" +connectionManagerTraceMap (TrTerminatingConnection p _) = + "TrTerminatingConnection " ++ show p +connectionManagerTraceMap (TrTerminatedConnection p _) = + "TrTerminatedConnection " ++ show p +connectionManagerTraceMap (TrConnectionHandler _ _) = + "TrConnectionHandler" +connectionManagerTraceMap TrShutdown = + "TrShutdown" +connectionManagerTraceMap (TrConnectionExists p _ as) = + "TrConnectionExists " ++ show p ++ " " ++ show as +connectionManagerTraceMap (TrForbiddenConnection _) = + "TrForbiddenConnection" +connectionManagerTraceMap (TrImpossibleConnection _) = + "TrImpossibleConnection" +connectionManagerTraceMap (TrConnectionFailure _) = + "TrConnectionFailure" +connectionManagerTraceMap (TrConnectionNotFound p _) = + "TrConnectionNotFound " ++ show p +connectionManagerTraceMap (TrForbiddenOperation _ as) = + "TrForbiddenOperation" ++ show as +connectionManagerTraceMap (TrPruneConnections _ _ _) = + "TrPruneConnections" +connectionManagerTraceMap (TrConnectionCleanup _) = + "TrConnectionCleanup" +connectionManagerTraceMap (TrConnectionTimeWait _) = + "TrConnectionTimeWait" +connectionManagerTraceMap (TrConnectionTimeWaitDone _) = + "TrConnectionTimeWaitDone" +connectionManagerTraceMap (TrConnectionManagerCounters _) = + "TrConnectionManagerCounters" +connectionManagerTraceMap (TrState _) = + "TrState" +connectionManagerTraceMap (TrUnknownConnection _) = + "TrUnknownConnection" +connectionManagerTraceMap (TrUnexpectedlyFalseAssertion _) = + "TrUnexpectedlyFalseAssertion" diff --git a/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs b/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs index e1ef4bdfc3e..5cc8ded9e37 100644 --- a/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs +++ b/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs @@ -7,8 +7,10 @@ module TestLib.InboundGovernor where import Test.QuickCheck import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.InboundGovernor (RemoteSt (..)) -import Ouroboros.Network.Server2 (RemoteTransition) +import Ouroboros.Network.InboundGovernor (InboundGovernorTrace (..), + RemoteSt (..)) +import qualified Ouroboros.Network.InboundGovernor as IG +import Ouroboros.Network.Server2 (RemoteTransition, ServerTrace (..)) import TestLib.Utils @@ -166,3 +168,49 @@ verifyRemoteTransitionOrder checkLast (h:t) = go t h remoteStrIsFinalTransition :: Transition' (Maybe RemoteSt) -> Bool remoteStrIsFinalTransition (Transition _ Nothing) = True remoteStrIsFinalTransition _ = False + +inboundGovernorTraceMap :: InboundGovernorTrace ntnAddr -> String +inboundGovernorTraceMap (TrNewConnection p _) = + "TrNewConnection " ++ show p +inboundGovernorTraceMap (TrResponderRestarted _ mpn) = + "TrResponderRestarted " ++ show mpn +inboundGovernorTraceMap (TrResponderStartFailure _ mpn se) = + "TrResponderStartFailure " ++ show mpn ++ " " ++ show se +inboundGovernorTraceMap (TrResponderErrored _ mpn se) = + "TrResponderErrored " ++ show mpn ++ " " ++ show se +inboundGovernorTraceMap (TrResponderStarted _ mpn) = + "TrResponderStarted " ++ show mpn +inboundGovernorTraceMap (TrResponderTerminated _ mpn) = + "TrResponderTerminated " ++ show mpn +inboundGovernorTraceMap (TrPromotedToWarmRemote _ ora) = + "TrPromotedToWarmRemote " ++ show ora +inboundGovernorTraceMap (TrPromotedToHotRemote _) = + "TrPromotedToHotRemote" +inboundGovernorTraceMap (TrDemotedToWarmRemote _) = + "TrDemotedToWarmRemote" +inboundGovernorTraceMap (TrDemotedToColdRemote _ ora) = + "TrDemotedToColdRemote " ++ show ora +inboundGovernorTraceMap (TrWaitIdleRemote _ ora) = + "TrWaitIdleRemote " ++ show ora +inboundGovernorTraceMap (TrMuxCleanExit _) = + "TrMuxCleanExit" +inboundGovernorTraceMap (TrMuxErrored _ se) = + "TrMuxErrored " ++ show se +inboundGovernorTraceMap (TrInboundGovernorCounters _) = + "TrInboundGovernorCounters" +inboundGovernorTraceMap (TrRemoteState _) = + "TrRemoteState" +inboundGovernorTraceMap (IG.TrUnexpectedlyFalseAssertion _) = + "TrUnexpectedlyFalseAssertion" +inboundGovernorTraceMap (TrInboundGovernorError se) = + "TrInboundGovernorError " ++ show se + + +serverTraceMap :: Show ntnAddr => ServerTrace ntnAddr -> String +serverTraceMap (TrAcceptConnection _) = "TrAcceptConnection" +serverTraceMap st@(TrAcceptError _) = show st +serverTraceMap st@(TrAcceptPolicyTrace _) = show st +serverTraceMap (TrServerStarted _) = "TrServerStarted" +serverTraceMap st@TrServerStopped = show st +serverTraceMap st@(TrServerError _) = show st + diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs index 8723c0d6916..919b5d74278 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs @@ -98,8 +98,13 @@ tests = testGroup "progress" [ testProperty "gossip reachable" prop_governor_gossip_1hr --- , testProperty "progresses towards public root peers target (from below)" --- prop_governor_target_publicroots + , testProperty "progresses towards root peers target (from below)" + prop_governor_target_root_below + + , testProperty "progresses towards established public root peers" + prop_governor_target_established_public + , testProperty "progresses towards active public root peers" + prop_governor_target_active_public , testProperty "progresses towards known peers target (from below)" prop_governor_target_known_below @@ -753,6 +758,172 @@ check_governor_connstatus _ trace0 = -- Progress properties -- +-- | A variant of 'prop_governor_target_established_below' but for the target +-- number of root peers. +-- +-- Check that the governor can hit (but not overshoot) its target for the +-- number of root peers. This has to be bounded by what is possible: we cannot +-- always find enough peers, and when we can, some of them fail. +-- +prop_governor_target_root_below :: GovernorMockEnvironment -> Property +prop_governor_target_root_below env = + let events = Signal.eventsFromListUpToTime (Time (10 * 60 * 60)) + . selectPeerSelectionTraceEvents + . runGovernorInMockEnvironment + $ env + + envTargetsSig :: Signal Int + envTargetsSig = + selectEnvTargets targetNumberOfRootPeers events + + govLocalRootPeersSig :: Signal (Set PeerAddr) + govLocalRootPeersSig = + selectGovState (LocalRootPeers.keysSet . Governor.localRootPeers) events + + govPublicRootPeersSig :: Signal (Set PeerAddr) + govPublicRootPeersSig = + selectGovState Governor.publicRootPeers events + + govRootPeersSig :: Signal (Set PeerAddr) + govRootPeersSig = Set.union <$> govLocalRootPeersSig <*> govPublicRootPeersSig + + -- There are no opportunities if we're at or above target + -- + requestOpportunity target public roots + | Set.size roots >= target + = Set.empty + + | otherwise + = public Set.\\ roots + + requestOpportunities :: Signal (Set PeerAddr) + requestOpportunities = + requestOpportunity + <$> envTargetsSig + <*> govPublicRootPeersSig + <*> govRootPeersSig + + requestOpportunitiesIgnoredTooLong :: Signal (Set PeerAddr) + requestOpportunitiesIgnoredTooLong = + Signal.keyedTimeout + 10 -- seconds + id + requestOpportunities + + in counterexample + ("\nSignal key: (target, local peers, public peers, root peers, " ++ + "opportunities, ignored too long)") $ + + signalProperty 20 show + (\(_,_,_,_,_,toolong) -> Set.null toolong) + ((,,,,,) <$> envTargetsSig + <*> govLocalRootPeersSig + <*> govPublicRootPeersSig + <*> govRootPeersSig + <*> requestOpportunities + <*> requestOpportunitiesIgnoredTooLong) + +-- | A variant of 'prop_governor_target_established_below' but for the target +-- that any public root peers should become established. +-- +-- We do not need separate above and below variants of this property since it +-- is not possible to exceed the target. +-- +prop_governor_target_established_public :: GovernorMockEnvironment -> Property +prop_governor_target_established_public env = + let events = Signal.eventsFromListUpToTime (Time (10 * 60 * 60)) + . selectPeerSelectionTraceEvents + . runGovernorInMockEnvironment + $ env + + govPublicRootPeersSig :: Signal (Set PeerAddr) + govPublicRootPeersSig = + selectGovState Governor.publicRootPeers + events + + govEstablishedPeersSig :: Signal (Set PeerAddr) + govEstablishedPeersSig = + selectGovState + (EstablishedPeers.toSet . Governor.establishedPeers) + events + + govInProgressPromoteColdSig :: Signal (Set PeerAddr) + govInProgressPromoteColdSig = + selectGovState + Governor.inProgressPromoteCold + events + + publicInEstablished :: Signal Bool + publicInEstablished = + (\publicPeers established inProgressPromoteCold -> + Set.size + (publicPeers `Set.intersection` + (established `Set.union` inProgressPromoteCold)) + > 0 + ) <$> govPublicRootPeersSig + <*> govEstablishedPeersSig + <*> govInProgressPromoteColdSig + + meaning :: Bool -> String + meaning False = "No PublicPeers in Established Set" + meaning True = "PublicPeers in Established Set" + + valuesList :: [String] + valuesList = map (meaning . snd) + . Signal.eventsToList + . Signal.toChangeEvents + $ publicInEstablished + + in checkCoverage + $ coverTable "established public peers" + [("PublicPeers in Established Set", 1)] + $ tabulate "established public peers" valuesList + $ True + +-- | A variant of 'prop_governor_target_active_below' but for checking if any +-- number of public root peers becomes active, since there's no target for +-- how many public root peers should be active. +-- +prop_governor_target_active_public :: GovernorMockEnvironment -> Property +prop_governor_target_active_public env = + let events = Signal.eventsFromListUpToTime (Time (10 * 60 * 60)) + . selectPeerSelectionTraceEvents + . runGovernorInMockEnvironment + $ env + + govPublicRootPeersSig :: Signal (Set PeerAddr) + govPublicRootPeersSig = + selectGovState Governor.publicRootPeers events + + govActivePeersSig :: Signal (Set PeerAddr) + govActivePeersSig = + selectGovState Governor.activePeers events + + publicInActive :: Signal Bool + publicInActive = + (\publicPeers active -> + Set.size + (publicPeers `Set.intersection` active) + > 0 + ) <$> govPublicRootPeersSig + <*> govActivePeersSig + + meaning :: Bool -> String + meaning False = "No PublicPeers in Active Set" + meaning True = "PublicPeers in Active Set" + + valuesList :: [String] + valuesList = map (meaning . snd) + . Signal.eventsToList + . Signal.toChangeEvents + $ publicInActive + + in checkCoverage + $ coverTable "active public peers" + [("PublicPeers in Active Set", 1)] + $ tabulate "active public peers" valuesList + $ True + -- | The main progress property for known peers: that we make progress towards -- the target for known peers from below. See 'prop_governor_target_known_above' -- for the (simpler) corresponding property for hitting the target from above. diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index 5d7d535d57f..cf97b082a56 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs @@ -5,12 +5,11 @@ module Test.Ouroboros.Network.Testnet (tests) where -import Control.Monad.Class.MonadTime (DiffTime, Time (Time), diffTime) +import Control.Monad.Class.MonadTime (DiffTime, Time (Time), addTime, + diffTime) import Control.Monad.IOSim import Control.Monad.IOSim.Types (ThreadId) import Control.Tracer (Tracer (Tracer), contramap, nullTracer) - -import Control.Monad.Class.MonadTime (addTime) import Data.Bifoldable (bifoldMap) import Data.Dynamic (Typeable) @@ -33,20 +32,24 @@ import qualified Network.DNS.Types as DNS import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.Diffusion.P2P (RemoteTransitionTrace, - TracersExtra (..)) +import Ouroboros.Network.Diffusion.P2P (TracersExtra (..)) import qualified Ouroboros.Network.Diffusion.P2P as Diff.P2P +import Ouroboros.Network.InboundGovernor hiding + (TrUnexpectedlyFalseAssertion) import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as EstablishedPeers import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), TracePeerSelection (..)) import qualified Ouroboros.Network.PeerSelection.Governor as Governor import qualified Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeers +import Ouroboros.Network.PeerSelection.PeerStateActions + (PeerSelectionActionsTrace (..)) import Ouroboros.Network.PeerSelection.RootPeersDNS (TraceLocalRootPeers (..), TracePublicRootPeers (..), dapDomain) import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSorIOError (DNSError)) import Ouroboros.Network.PeerSelection.Types (PeerStatus (..)) +import Ouroboros.Network.Server2 (ServerTrace (..)) import Ouroboros.Network.Testing.Data.AbsBearerInfo (AbsBearerInfo (..), attenuation, delay, toSduSize) import Ouroboros.Network.Testing.Data.Signal (Events, Signal, @@ -56,7 +59,6 @@ import Ouroboros.Network.Testing.Utils (WithName (..), WithTime (..), sayTracer, splitWithNameTrace, tracerWithName, tracerWithTime) - import Simulation.Network.Snocket (BearerInfo (..)) import Test.Ouroboros.Network.Diffusion.Node.NodeKernel @@ -65,15 +67,18 @@ import Test.Ouroboros.Network.Testnet.Simulation.Node diffusionSimulation, prop_diffusionScript_commandScript_valid, prop_diffusionScript_fixupCommands) -import Test.QuickCheck (Property, classify, conjoin, counterexample, - property) +import Test.QuickCheck (Property, checkCoverage, classify, conjoin, + counterexample, coverTable, property, tabulate) import Test.Tasty import Test.Tasty.QuickCheck (testProperty) import TestLib.ConnectionManager (abstractStateIsFinalTransition, + connectionManagerTraceMap, validTransitionMap, verifyAbstractTransition, verifyAbstractTransitionOrder) -import TestLib.InboundGovernor (remoteStrIsFinalTransition, - verifyRemoteTransition, verifyRemoteTransitionOrder) +import TestLib.InboundGovernor (inboundGovernorTraceMap, + remoteStrIsFinalTransition, serverTraceMap, + validRemoteTransitionMap, verifyRemoteTransition, + verifyRemoteTransitionOrder) import TestLib.Utils (AllProperty (..), TestProperty (..), classifyActivityType, classifyEffectiveDataFlow, classifyNegotiatedDataFlow, classifyPrunings, @@ -92,6 +97,10 @@ tests = prop_diffusion_nolivelock , testProperty "diffusion dns can recover from fails" prop_diffusion_dns_can_recover + , testProperty "diffusion target established public" + prop_diffusion_target_established_public + , testProperty "diffusion target active public" + prop_diffusion_target_active_public , testProperty "diffusion target established local" prop_diffusion_target_established_local , testProperty "diffusion target active below" @@ -109,6 +118,22 @@ tests = , testProperty "diffusion cm & ig timeouts enforced" prop_diffusion_timeouts_enforced ] + , testGroup "coverage" + [ testProperty "diffusion server trace coverage" + prop_server_trace_coverage + , testProperty "diffusion peer selection actions trace coverage" + prop_peer_selection_action_trace_coverage + , testProperty "diffusion peer selection trace coverage" + prop_peer_selection_trace_coverage + , testProperty "diffusion connection manager trace coverage" + prop_connection_manager_trace_coverage + , testProperty "diffusion connection manager transitions coverage" + prop_connection_manager_transitions_coverage + , testProperty "diffusion inbound governor trace coverage" + prop_inbound_governor_trace_coverage + , testProperty "diffusion inbound governor transitions coverage" + prop_inbound_governor_transitions_coverage + ] ] @@ -123,6 +148,7 @@ data DiffusionTestTrace = DiffusionLocalRootPeerTrace (TraceLocalRootPeers NtNAddr SomeException) | DiffusionPublicRootPeerTrace TracePublicRootPeers | DiffusionPeerSelectionTrace (TracePeerSelection NtNAddr) + | DiffusionPeerSelectionActionsTrace (PeerSelectionActionsTrace NtNAddr) | DiffusionDebugPeerSelectionTrace (DebugPeerSelection NtNAddr ()) | DiffusionConnectionManagerTrace (ConnectionManagerTrace NtNAddr @@ -132,6 +158,8 @@ data DiffusionTestTrace = (AbstractTransitionTrace NtNAddr) | DiffusionInboundGovernorTransitionTrace (RemoteTransitionTrace NtNAddr) + | DiffusionInboundGovernorTrace (InboundGovernorTrace NtNAddr) + | DiffusionServerTrace (ServerTrace NtNAddr) deriving (Show) tracersExtraWithTimeName @@ -172,7 +200,11 @@ tracersExtraWithTimeName ntnAddr = . tracerWithTime $ dynamicTracer , dtTracePeerSelectionCounters = nullTracer - , dtPeerSelectionActionsTracer = nullTracer + , dtPeerSelectionActionsTracer = contramap + DiffusionPeerSelectionActionsTrace + . tracerWithName ntnAddr + . tracerWithTime + $ dynamicTracer , dtConnectionManagerTracer = contramap DiffusionConnectionManagerTrace . tracerWithName ntnAddr @@ -183,8 +215,15 @@ tracersExtraWithTimeName ntnAddr = . tracerWithName ntnAddr . tracerWithTime $ dynamicTracer - , dtServerTracer = nullTracer - , dtInboundGovernorTracer = nullTracer + , dtServerTracer = contramap DiffusionServerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ dynamicTracer + , dtInboundGovernorTracer = contramap + DiffusionInboundGovernorTrace + . tracerWithName ntnAddr + . tracerWithTime + $ dynamicTracer , dtInboundGovernorTransitionTracer = contramap DiffusionInboundGovernorTransitionTrace . tracerWithName ntnAddr @@ -202,6 +241,317 @@ tracerDiffusionSimWithTimeName ntnAddr = . tracerWithTime $ dynamicTracer + +-- | This test coverage of ServerTrace constructors, namely accept errors. +-- +prop_connection_manager_trace_coverage :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_connection_manager_trace_coverage defaultBearerInfo diffScript = + + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo defaultBearerInfo) + diffScript + tracersExtraWithTimeName + tracerDiffusionSimWithTimeName + + events :: [ConnectionManagerTrace + NtNAddr + (ConnectionHandlerTrace NtNVersion NtNVersionData)] + events = mapMaybe (\case DiffusionConnectionManagerTrace st -> Just st + _ -> Nothing + ) + . Trace.toList + . fmap (\(WithTime _ (WithName _ b)) -> b) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.fromList (MainReturn (Time 0) () []) + . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) + . take 125000 + . traceEvents + $ runSimTrace sim + + eventsSeenNames = map connectionManagerTraceMap events + + -- TODO: Add checkCoverage here + in tabulate "connection manager trace" eventsSeenNames + True + +-- | This tests coverage of ConnectionManager transitions. +-- +prop_connection_manager_transitions_coverage :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_connection_manager_transitions_coverage defaultBearerInfo diffScript = + + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo defaultBearerInfo) + diffScript + tracersExtraWithTimeName + tracerDiffusionSimWithTimeName + + events :: [AbstractTransitionTrace NtNAddr] + events = mapMaybe (\case DiffusionConnectionManagerTransitionTrace st -> + Just st + _ -> Nothing + ) + . Trace.toList + . fmap (\(WithTime _ (WithName _ b)) -> b) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.fromList (MainReturn (Time 0) () []) + . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) + . take 125000 + . traceEvents + $ runSimTrace sim + + + transitionsSeenNames = map (snd . validTransitionMap . ttTransition) + events + + -- TODO: Add checkCoverage here + in tabulate "connection manager transitions" transitionsSeenNames + True + +-- | This test coverage of ServerTrace constructors, namely accept errors. +-- +prop_inbound_governor_trace_coverage :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_inbound_governor_trace_coverage defaultBearerInfo diffScript = + + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo defaultBearerInfo) + diffScript + tracersExtraWithTimeName + tracerDiffusionSimWithTimeName + + events :: [InboundGovernorTrace NtNAddr] + events = mapMaybe (\case DiffusionInboundGovernorTrace st -> Just st + _ -> Nothing + ) + . Trace.toList + . fmap (\(WithTime _ (WithName _ b)) -> b) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.fromList (MainReturn (Time 0) () []) + . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) + . take 125000 + . traceEvents + $ runSimTrace sim + + eventsSeenNames = map inboundGovernorTraceMap events + + -- TODO: Add checkCoverage here + in tabulate "inbound governor trace" eventsSeenNames + True + +-- | This test coverage of InboundGovernor transitions. +-- +prop_inbound_governor_transitions_coverage :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_inbound_governor_transitions_coverage defaultBearerInfo diffScript = + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo defaultBearerInfo) + diffScript + tracersExtraWithTimeName + tracerDiffusionSimWithTimeName + + events :: [RemoteTransitionTrace NtNAddr] + events = mapMaybe (\case DiffusionInboundGovernorTransitionTrace st -> + Just st + _ -> Nothing + ) + . Trace.toList + . fmap (\(WithTime _ (WithName _ b)) -> b) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.fromList (MainReturn (Time 0) () []) + . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) + . take 125000 + . traceEvents + $ runSimTrace sim + + transitionsSeenNames = map (snd . validRemoteTransitionMap . ttTransition) + events + + -- TODO: Add checkCoverage here + in tabulate "inbound governor transitions" transitionsSeenNames + True + +-- | This test coverage of ServerTrace constructors, namely accept errors. +-- +prop_server_trace_coverage :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_server_trace_coverage defaultBearerInfo diffScript = + + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo defaultBearerInfo) + diffScript + tracersExtraWithTimeName + tracerDiffusionSimWithTimeName + + events :: [ServerTrace NtNAddr] + events = mapMaybe (\case DiffusionServerTrace st -> Just st + _ -> Nothing + ) + . Trace.toList + . fmap (\(WithTime _ (WithName _ b)) -> b) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.fromList (MainReturn (Time 0) () []) + . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) + . take 125000 + . traceEvents + $ runSimTrace sim + + eventsSeenNames = map serverTraceMap events + + -- TODO: Add checkCoverage here + in tabulate "server trace" eventsSeenNames + True + +-- | This test coverage of PeerSelectionActionsTrace constructors. +-- +prop_peer_selection_action_trace_coverage :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_peer_selection_action_trace_coverage defaultBearerInfo diffScript = + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo defaultBearerInfo) + diffScript + tracersExtraWithTimeName + tracerDiffusionSimWithTimeName + + events :: [PeerSelectionActionsTrace NtNAddr] + events = mapMaybe (\case DiffusionPeerSelectionActionsTrace st -> Just st + _ -> Nothing + ) + . Trace.toList + . fmap (\(WithTime _ (WithName _ b)) -> b) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.fromList (MainReturn (Time 0) () []) + . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) + . take 125000 + . traceEvents + $ runSimTrace sim + + peerSelectionActionsTraceMap :: PeerSelectionActionsTrace NtNAddr -> String + peerSelectionActionsTraceMap (PeerStatusChanged _) = + "PeerStatusChanged" + peerSelectionActionsTraceMap (PeerStatusChangeFailure _ ft) = + "PeerStatusChangeFailure " ++ show ft + peerSelectionActionsTraceMap (PeerMonitoringError _ se) = + "PeerMonitoringError " ++ show se + peerSelectionActionsTraceMap (PeerMonitoringResult _ wspt) = + "PeerMonitoringResult " ++ show wspt + + eventsSeenNames = map peerSelectionActionsTraceMap events + + -- TODO: Add checkCoverage here + in tabulate "peer selection actions trace" eventsSeenNames + True + +-- | This test coverage of TracePeerSelection constructors. +-- +prop_peer_selection_trace_coverage :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_peer_selection_trace_coverage defaultBearerInfo diffScript = + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo defaultBearerInfo) + diffScript + tracersExtraWithTimeName + tracerDiffusionSimWithTimeName + + events :: [TracePeerSelection NtNAddr] + events = mapMaybe (\case DiffusionPeerSelectionTrace st -> Just st + _ -> Nothing + ) + . Trace.toList + . fmap (\(WithTime _ (WithName _ b)) -> b) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.fromList (MainReturn (Time 0) () []) + . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) + . take 125000 + . traceEvents + $ runSimTrace sim + + peerSelectionTraceMap :: TracePeerSelection NtNAddr -> String + peerSelectionTraceMap (TraceLocalRootPeersChanged _ _) = + "TraceLocalRootPeersChanged" + peerSelectionTraceMap (TraceTargetsChanged _ _) = + "TraceTargetsChanged" + peerSelectionTraceMap (TracePublicRootsRequest _ _) = + "TracePublicRootsRequest" + peerSelectionTraceMap (TracePublicRootsResults _ _ _) = + "TracePublicRootsResults" + peerSelectionTraceMap (TracePublicRootsFailure se _ _) = + "TracePublicRootsFailure " ++ show se + peerSelectionTraceMap (TraceGossipRequests _ _ _ _) = + "TraceGossipRequests" + peerSelectionTraceMap (TraceGossipResults _) = + "TraceGossipResults" + peerSelectionTraceMap (TraceForgetColdPeers _ _ _) = + "TraceForgetColdPeers" + peerSelectionTraceMap (TracePromoteColdPeers _ _ _) = + "TracePromoteColdPeers" + peerSelectionTraceMap (TracePromoteColdLocalPeers _ _ _) = + "TracePromoteColdLocalPeers" + peerSelectionTraceMap (TracePromoteColdFailed _ _ _ _ _) = + "TracePromoteColdFailed" + peerSelectionTraceMap (TracePromoteColdDone _ _ _) = + "TracePromoteColdDone" + peerSelectionTraceMap (TracePromoteWarmPeers _ _ _) = + "TracePromoteWarmPeers" + peerSelectionTraceMap (TracePromoteWarmLocalPeers _ _) = + "TracePromoteWarmLocalPeers" + peerSelectionTraceMap (TracePromoteWarmFailed _ _ _ _) = + "TracePromoteWarmFailed" + peerSelectionTraceMap (TracePromoteWarmDone _ _ _) = + "TracePromoteWarmDone" + peerSelectionTraceMap (TracePromoteWarmAborted _ _ _) = + "TracePromoteWarmAborted" + peerSelectionTraceMap (TraceDemoteWarmPeers _ _ _) = + "TraceDemoteWarmPeers" + peerSelectionTraceMap (TraceDemoteWarmFailed _ _ _ _) = + "TraceDemoteWarmFailed" + peerSelectionTraceMap (TraceDemoteWarmDone _ _ _) = + "TraceDemoteWarmDone" + peerSelectionTraceMap (TraceDemoteHotPeers _ _ _) = + "TraceDemoteHotPeers" + peerSelectionTraceMap (TraceDemoteLocalHotPeers _ _) = + "TraceDemoteLocalHotPeers" + peerSelectionTraceMap (TraceDemoteHotFailed _ _ _ _) = + "TraceDemoteHotFailed" + peerSelectionTraceMap (TraceDemoteHotDone _ _ _) = + "TraceDemoteHotDone" + peerSelectionTraceMap (TraceDemoteAsynchronous _) = + "TraceDemoteAsynchronous" + peerSelectionTraceMap TraceGovernorWakeup = + "TraceGovernorWakeup" + peerSelectionTraceMap (TraceChurnWait _) = + "TraceChurnWait" + peerSelectionTraceMap (TraceChurnMode cm) = + "TraceChurnMode " ++ show cm + + eventsSeenNames = map peerSelectionTraceMap events + + -- TODO: Add checkCoverage here + in tabulate "peer selection trace" eventsSeenNames + True + -- | 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 @@ -383,6 +733,185 @@ prop_diffusion_dns_can_recover defaultBearerInfo diffScript = verify Map.empty recovered t evs _ -> verify toRecover recovered time evs +-- | A variant of +-- 'Test.Ouroboros.Network.PeerSelection.prop_governor_target_established_public' +-- 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. +-- +-- We do not need separate above and below variants of this property since it +-- is not possible to exceed the target. +-- +prop_diffusion_target_established_public :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_diffusion_target_established_public defaultBearerInfo diffScript = + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo defaultBearerInfo) + diffScript + tracersExtraWithTimeName + tracerDiffusionSimWithTimeName + + events :: [Events DiffusionTestTrace] + events = fmap ( Signal.eventsFromList + . fmap (\(WithName _ (WithTime t b)) -> (t, b)) + ) + . Trace.toList + . splitWithNameTrace + . Trace.fromList () + . fmap snd + . 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 125000 + . traceEvents + $ runSimTrace sim + + in conjoin + $ (\ev -> + let evsList = eventsToList ev + lastTime = fst + . last + $ evsList + in classifySimulatedTime lastTime + $ classifyNumberOfEvents (length evsList) + $ verify_target_established_public ev + ) + <$> events + where + verify_target_established_public :: Events DiffusionTestTrace -> Property + verify_target_established_public events = + let govPublicRootPeersSig :: Signal (Set NtNAddr) + govPublicRootPeersSig = + selectDiffusionPeerSelectionState + Governor.publicRootPeers + events + + govEstablishedPeersSig :: Signal (Set NtNAddr) + govEstablishedPeersSig = + selectDiffusionPeerSelectionState + (EstablishedPeers.toSet . Governor.establishedPeers) + events + + govInProgressPromoteColdSig :: Signal (Set NtNAddr) + govInProgressPromoteColdSig = + selectDiffusionPeerSelectionState + Governor.inProgressPromoteCold + events + + publicInEstablished :: Signal Bool + publicInEstablished = + (\publicPeers established inProgressPromoteCold -> + Set.size + (publicPeers `Set.intersection` + (established `Set.union` inProgressPromoteCold)) + > 0 + ) <$> govPublicRootPeersSig + <*> govEstablishedPeersSig + <*> govInProgressPromoteColdSig + + meaning :: Bool -> String + meaning False = "No PublicPeers in Established Set" + meaning True = "PublicPeers in Established Set" + + valuesList :: [String] + valuesList = map (meaning . snd) + . Signal.eventsToList + . Signal.toChangeEvents + $ publicInEstablished + + in checkCoverage + $ coverTable "established public peers" + [("PublicPeers in Established Set", 1)] + $ tabulate "established public peers" valuesList + $ True + +-- | A variant of +-- 'Test.Ouroboros.Network.PeerSelection.prop_governor_target_active_public' +-- 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_target_active_public :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_diffusion_target_active_public defaultBearerInfo diffScript = + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo defaultBearerInfo) + diffScript + tracersExtraWithTimeName + tracerDiffusionSimWithTimeName + + events :: [Events DiffusionTestTrace] + events = fmap ( Signal.eventsFromList + . fmap (\(WithName _ (WithTime t b)) -> (t, b)) + ) + . Trace.toList + . splitWithNameTrace + . Trace.fromList () + . fmap snd + . 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 125000 + . traceEvents + $ runSimTrace sim + + in conjoin + $ (\ev -> + let evsList = eventsToList ev + lastTime = fst + . last + $ evsList + in classifySimulatedTime lastTime + $ classifyNumberOfEvents (length evsList) + $ verify_target_active_public ev + ) + <$> events + where + verify_target_active_public :: Events DiffusionTestTrace -> Property + verify_target_active_public events = + let govPublicRootPeersSig :: Signal (Set NtNAddr) + govPublicRootPeersSig = + selectDiffusionPeerSelectionState Governor.publicRootPeers events + + govActivePeersSig :: Signal (Set NtNAddr) + govActivePeersSig = + selectDiffusionPeerSelectionState Governor.activePeers events + + publicInActive :: Signal Bool + publicInActive = + (\publicPeers active -> + Set.size + (publicPeers `Set.intersection` active) + > 0 + ) <$> govPublicRootPeersSig + <*> govActivePeersSig + + meaning :: Bool -> String + meaning False = "No PublicPeers in Active Set" + meaning True = "PublicPeers in Active Set" + + valuesList :: [String] + valuesList = map (meaning . snd) + . Signal.eventsToList + . Signal.toChangeEvents + $ publicInActive + + in checkCoverage + $ coverTable "active public peers" + [("PublicPeers in Active Set", 1)] + $ tabulate "active public peers" valuesList + $ True + -- | A variant of -- 'Test.Ouroboros.Network.PeerSelection.prop_governor_target_established_local' -- but for running on Diffusion. This means it has to have in consideration the diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs index b595246b301..df35818ef58 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs @@ -148,20 +148,20 @@ genIP ips = genCommands :: [(Int, Map RelayAccessPoint PeerAdvertise)] -> Gen [Command] genCommands localRoots = sized $ \size -> do port <- fromIntegral <$> (arbitrary :: Gen Int) - commands <- vectorOf size (frequency [ (7, JoinNetwork + commands <- vectorOf size (frequency [ (10, JoinNetwork <$> delay <*> ( Just . TestAddress . flip IPAddr port <$> genIP [] )) - , (7, JoinNetwork + , (10, JoinNetwork <$> delay <*> pure Nothing) - , (4, Reconfigure + , (6, Reconfigure <$> delay <*> subLocalRootPeers) - , (1, Kill <$> delay) + , (3, Kill <$> delay) ]) return (fixupCommands commands) where @@ -203,7 +203,7 @@ instance Arbitrary DiffusionScript where arbitrary = do -- Limit the number of nodes to run in Simulation otherwise it is going -- to take very long time for tests to run - size <- chooseInt (0, 3) + size <- chooseInt (0, 5) raps <- nub <$> vectorOf size arbitrary let toRunRaps = [ r | r@(RelayAccessAddress _ _) <- raps ]