From ee14be2dc4ad257fc4235a280a51d05514ba9493 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Wed, 20 Apr 2022 15:24:46 +0100 Subject: [PATCH 1/8] Refactored common functions into testlib --- .../ouroboros-network-framework.cabal | 33 +- .../Ouroboros/Network/ConnectionManager.hs | 216 +------- .../test/Test/Ouroboros/Network/Server2.hs | 520 +----------------- .../testlib/TestLib/ConnectionManager.hs | 254 +++++++++ .../testlib/TestLib/InboundGovernor.hs | 165 ++++++ .../testlib/TestLib/Utils.hs | 291 ++++++++++ 6 files changed, 766 insertions(+), 713 deletions(-) create mode 100644 ouroboros-network-framework/testlib/TestLib/ConnectionManager.hs create mode 100644 ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs create mode 100644 ouroboros-network-framework/testlib/TestLib/Utils.hs diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index c48c9634b51..16234f43a88 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -1,4 +1,4 @@ -cabal-version: >=1.10 +cabal-version: 3.0 -- Initial package description 'typed-protocols-testing.cabal' generated by -- 'cabal init'. For further documentation, see -- http://haskell.org/cabal/users-guide/ @@ -115,6 +115,36 @@ library -Wredundant-constraints -Wno-unticked-promoted-constructors +library testlib + visibility: public + hs-source-dirs: testlib + + exposed-modules: TestLib.ConnectionManager + TestLib.InboundGovernor + TestLib.Utils + + other-modules: + + build-depends: base + , bytestring + , containers + + , QuickCheck + + , io-sim + , ouroboros-network-framework + + default-language: Haskell2010 + ghc-options: -rtsopts + -threaded + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + test-suite test type: exitcode-stdio-1.0 main-is: Main.hs @@ -157,6 +187,7 @@ test-suite test , network-mux , monoidal-synchronisation , ouroboros-network-framework + , ouroboros-network-framework:testlib , ouroboros-network-testing , typed-protocols , typed-protocols-cborg diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/ConnectionManager.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/ConnectionManager.hs index 79737604094..7b6388e0141 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/ConnectionManager.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/ConnectionManager.hs @@ -1,18 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnicodeSyntax #-} -- 'TestAddress' 'Arbitrary' instance. @@ -24,9 +19,6 @@ module Test.Ouroboros.Network.ConnectionManager ( tests - , verifyAbstractTransition - , validTransitionMap - , allValidTransitionsNames ) where import Prelude hiding (read) @@ -73,6 +65,8 @@ import Ouroboros.Network.Server.RateLimiting import Ouroboros.Network.Snocket (Accept (..), Accepted (..), AddressFamily (TestFamily), Snocket (..), TestAddress (..)) +import TestLib.ConnectionManager (verifyAbstractTransition) + tests :: TestTree @@ -653,212 +647,6 @@ type TestConnectionManagerTrace = ConnectionManagerTrace Addr () type TestTransitionTrace m = TransitionTrace Addr (TestConnectionState m) type TestAbstractTransitionTrace = AbstractTransitionTrace Addr - -verifyAbstractTransition :: AbstractTransition - -> Bool -verifyAbstractTransition Transition { fromState, toState } = - case (fromState, toState) of - -- - -- Outbound - -- - - -- @Reserve@ - (TerminatedSt, ReservedOutboundSt) -> True - (UnknownConnectionSt, ReservedOutboundSt) -> True - -- @Connected@ - (ReservedOutboundSt, UnnegotiatedSt Outbound) -> True - -- @Negotiated^{Unidirectional}_{Outbound}@ - (UnnegotiatedSt Outbound, OutboundUniSt) -> True - -- @Negotiated^{Duplex}_{Outbound}@ - (UnnegotiatedSt Outbound, OutboundDupSt Ticking) -> True - (UnnegotiatedSt _, TerminatingSt) -> True - - -- @DemotedToCold^{Unidirectional}_{Local}@ - (OutboundUniSt, OutboundIdleSt Unidirectional) -> True - -- @TimeoutExpired@ - (OutboundDupSt Ticking, OutboundDupSt Expired) -> True - -- @DemotedToCold^{Duplex}_{Local}@ - (OutboundDupSt Expired, OutboundIdleSt Duplex) -> True - -- identity transition executed by 'demotedToColdRemote' - (OutboundIdleSt dataFlow, OutboundIdleSt dataFlow') -> dataFlow == dataFlow' - - -- - -- Outbound ↔ Inbound - -- - - -- @DemotedToCold^{Duplex}_{Local}@ - (OutboundDupSt Ticking, InboundIdleSt Duplex) -> True - -- @Awake^{Duplex}_{Local} - (InboundIdleSt Duplex, OutboundDupSt Ticking) -> True - -- @PromotedToWarm^{Duplex}_{Remote}@ - (OutboundDupSt Ticking, DuplexSt) -> True - (OutboundDupSt Expired, DuplexSt) -> True - -- can be executed by 'demotedToColdRemote' - (OutboundDupSt expired, OutboundDupSt expired') - -> expired == expired' - -- @PromotedToWarm^{Duplex}_{Local}@ - (InboundSt Duplex, DuplexSt) -> True - -- @DemotedToCold^{Duplex}_{Remote}@ - (DuplexSt, OutboundDupSt Ticking) -> True - -- @DemotedToCold^{Duplex}_{Local}@ - (DuplexSt, InboundSt Duplex) -> True - - -- - -- Inbound - -- - - -- @Accepted@ - (TerminatedSt, UnnegotiatedSt Inbound) -> True - (UnknownConnectionSt, UnnegotiatedSt Inbound) -> True - -- @Overwritten@ - (ReservedOutboundSt, UnnegotiatedSt Inbound) -> True - -- @Negotiated^{Duplex}_{Inbound} - (UnnegotiatedSt Inbound, InboundIdleSt Duplex) -> True - -- @Negotiated^{Unidirectional}_{Inbound} - (UnnegotiatedSt Inbound, InboundIdleSt Unidirectional) -> True - - -- 'unregisterOutboundConnection' and 'demotedToColdRemote' might perfrom - (InboundIdleSt Duplex, InboundIdleSt Duplex) -> True - -- @Awake^{Duplex}_{Remote} - (InboundIdleSt Duplex, InboundSt Duplex) -> True - -- @Commit^{Duplex} - (InboundIdleSt Duplex, TerminatingSt) -> True - -- @DemotedToCold^{Duplex}_{Local} - (InboundSt Duplex, InboundIdleSt Duplex) -> True - - -- @Awake^{Unidirectional}_{Remote} - (InboundIdleSt Unidirectional, InboundSt Unidirectional) -> True - -- @Commit^{Unidirectional} - (InboundIdleSt Unidirectional, TerminatingSt) -> True - -- @DemotedToCold^{Unidirectional}_{Local} - (InboundSt Unidirectional, InboundIdleSt Unidirectional) -> True - - -- - -- OutboundIdleSt - -- - - (OutboundIdleSt Duplex, InboundSt Duplex) -> True - (OutboundIdleSt _dataFlow, TerminatingSt) -> True - - -- - -- Terminate - -- - - -- @Terminate@ - (TerminatingSt, TerminatedSt) -> True - - -- explicit prohibition of reflexive terminate transition - (TerminatedSt, TerminatedSt) -> False - -- implicit terminate transition - (_, TerminatedSt) -> True - - -- explicit prohibition of reflexive unknown transition - (UnknownConnectionSt, UnknownConnectionSt) -> False - (_, UnknownConnectionSt) -> True - - -- We accept connection in 'TerminatingSt' - (TerminatingSt, UnnegotiatedSt Inbound) -> True - - _ -> False - --- | Maps each valid transition into one number. Collapses all invalid transition into a --- single number. --- --- NOTE: Should be in sync with 'verifyAbstractTransition' --- -validTransitionMap :: AbstractTransition - -> (Int, String) -validTransitionMap t@Transition { fromState, toState } = - case (fromState, toState) of - (TerminatedSt , ReservedOutboundSt) -> (01, show t) - (UnknownConnectionSt , ReservedOutboundSt) -> (02, show t) - (ReservedOutboundSt , UnnegotiatedSt Outbound) -> (03, show t) - (UnnegotiatedSt Outbound , OutboundUniSt) -> (04, show t) - (UnnegotiatedSt Outbound , OutboundDupSt Ticking) -> (05, show t) - (OutboundUniSt , OutboundIdleSt Unidirectional) -> (06, show t) - (OutboundDupSt Ticking , OutboundDupSt Expired) -> (07, show t) - (OutboundDupSt Expired , OutboundIdleSt Duplex) -> (08, show t) - (OutboundIdleSt dataFlow , OutboundIdleSt dataFlow') - | dataFlow == dataFlow' -> (09, show t) - (OutboundDupSt Ticking , InboundIdleSt Duplex) -> (10, show t) - (InboundIdleSt Duplex , OutboundDupSt Ticking) -> (11, show t) - (OutboundDupSt Ticking , DuplexSt) -> (12, show t) - (OutboundDupSt Expired , DuplexSt) -> (13, show t) - (OutboundDupSt expired , OutboundDupSt expired') - | expired == expired' -> (14, show t) - (InboundSt Duplex , DuplexSt) -> (15, show t) - (DuplexSt , OutboundDupSt Ticking) -> (16, show t) - (DuplexSt , InboundSt Duplex) -> (17, show t) - (TerminatedSt , UnnegotiatedSt Inbound) -> (18, show t) - (UnknownConnectionSt , UnnegotiatedSt Inbound) -> (19, show t) - (ReservedOutboundSt , UnnegotiatedSt Inbound) -> (20, show t) - (UnnegotiatedSt Inbound , InboundIdleSt Duplex) -> (21, show t) - (UnnegotiatedSt Inbound , InboundIdleSt Unidirectional) -> (22, show t) - (InboundIdleSt Duplex , InboundIdleSt Duplex) -> (23, show t) - (InboundIdleSt Duplex , InboundSt Duplex) -> (24, show t) - (InboundIdleSt Duplex , TerminatingSt) -> (25, show t) - (InboundSt Duplex , InboundIdleSt Duplex) -> (26, show t) - (InboundIdleSt Unidirectional , InboundSt Unidirectional) -> (27, show t) - (InboundIdleSt Unidirectional , TerminatingSt) -> (28, show t) - (InboundSt Unidirectional , InboundIdleSt Unidirectional) -> (29, show t) - (OutboundIdleSt Duplex , InboundSt Duplex) -> (30, show t) - (OutboundIdleSt _dataFlow , TerminatingSt) -> (31, show t) - (TerminatingSt , TerminatedSt) -> (32, show t) - (_ , TerminatedSt) -> (33, show t) - (_ , UnknownConnectionSt) -> (34, show t) - (TerminatingSt , UnnegotiatedSt Inbound) -> (35, show t) - _ -> (99, show t) - --- | List of all valid transition's names. --- --- NOTE: Should be in sync with 'verifyAbstractTransition', but due to #3516 --- abrupt terminating transitions and identity transitions are trimmed for now, --- until we tweak the generators to include more connection errors. --- -allValidTransitionsNames :: [String] -allValidTransitionsNames = - map show - [ Transition UnknownConnectionSt ReservedOutboundSt - -- , Transition TerminatedSt ReservedOutboundSt - , Transition ReservedOutboundSt (UnnegotiatedSt Outbound) - , Transition (UnnegotiatedSt Outbound) OutboundUniSt - , Transition (UnnegotiatedSt Outbound) (OutboundDupSt Ticking) - , Transition OutboundUniSt (OutboundIdleSt Unidirectional) - , Transition (OutboundDupSt Ticking) (OutboundDupSt Expired) - -- , Transition (OutboundDupSt Expired) (OutboundIdleSt Duplex) - -- , Transition (OutboundIdleSt Unidirectional) (OutboundIdleSt Unidirectional) - -- , Transition (OutboundIdleSt Duplex) (OutboundIdleSt Duplex) - , Transition (OutboundDupSt Ticking) (InboundIdleSt Duplex) - , Transition (InboundIdleSt Duplex) (OutboundDupSt Ticking) - , Transition (OutboundDupSt Ticking) DuplexSt - -- , Transition (OutboundDupSt Expired) DuplexSt - -- , Transition (OutboundDupSt Ticking) (OutboundDupSt Ticking) - -- , Transition (OutboundDupSt Expired) (OutboundDupSt Expired) - , Transition (InboundSt Duplex) DuplexSt - , Transition DuplexSt (OutboundDupSt Ticking) - , Transition DuplexSt (InboundSt Duplex) - -- , Transition TerminatedSt (UnnegotiatedSt Inbound) - , Transition UnknownConnectionSt (UnnegotiatedSt Inbound) - , Transition ReservedOutboundSt (UnnegotiatedSt Inbound) - , Transition (UnnegotiatedSt Inbound) (InboundIdleSt Duplex) - , Transition (UnnegotiatedSt Inbound) (InboundIdleSt Unidirectional) - -- , Transition (InboundIdleSt Duplex) (InboundIdleSt Duplex) - , Transition (InboundIdleSt Duplex) (InboundSt Duplex) - -- , Transition (InboundIdleSt Duplex) TerminatingSt - -- , Transition (InboundSt Duplex) (InboundIdleSt Duplex) - -- , Transition (InboundIdleSt Unidirectional) (InboundSt Unidirectional) - -- , Transition (InboundIdleSt Unidirectional) TerminatingSt - -- , Transition (InboundSt Unidirectional) (InboundIdleSt Unidirectional) - -- , Transition (OutboundIdleSt Duplex) (InboundSt Duplex) - -- , Transition (OutboundIdleSt Unidirectional) TerminatingSt - -- , Transition (OutboundIdleSt Duplex) TerminatingSt - , Transition TerminatingSt TerminatedSt - -- , Transition TerminatedSt UnknownConnectionSt - -- , Transition TerminatingSt (UnnegotiatedSt Inbound) - -- , Transition (_) (TerminatedSt) - -- , Transition (_) (UnknownConnectionSt) - ] - newtype SkewedBool = SkewedBool Bool deriving Show diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index 42da27790ff..e58863fc97e 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -5,17 +5,14 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -- for 'debugTracer' {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -40,19 +37,18 @@ import Control.Tracer (Tracer (..), contramap, nullTracer) import Codec.Serialise.Class (Serialise) import Data.Bifoldable -import Data.Bitraversable import Data.Bool (bool) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LBS import Data.Foldable (foldMap') import Data.Functor (void, ($>), (<&>)) -import Data.List (delete, dropWhileEnd, find, foldl', intercalate, +import Data.List (delete, foldl', intercalate, mapAccumL, nub, (\\)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.Trace as Trace import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +import Data.Maybe (fromMaybe, isNothing) import Data.Monoid (Sum (..)) import Data.Monoid.Synchronisation (FirstToFinish (..)) import qualified Data.Set as Set @@ -88,8 +84,7 @@ import Ouroboros.Network.ConnectionManager.Types import qualified Ouroboros.Network.ConnectionManager.Types as CM import Ouroboros.Network.Driver.Limits import Ouroboros.Network.IOManager -import Ouroboros.Network.InboundGovernor (InboundGovernorTrace (..), - RemoteSt (..)) +import Ouroboros.Network.InboundGovernor (InboundGovernorTrace (..)) import qualified Ouroboros.Network.InboundGovernor as IG import qualified Ouroboros.Network.InboundGovernor.ControlChannel as Server import Ouroboros.Network.InboundGovernor.State @@ -108,8 +103,7 @@ import Ouroboros.Network.Protocol.Handshake.Version (Acceptable (..)) import Ouroboros.Network.RethrowPolicy import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Server2 (RemoteTransition, - RemoteTransitionTrace, ServerArguments (..)) +import Ouroboros.Network.Server2 (RemoteTransitionTrace, ServerArguments (..)) import qualified Ouroboros.Network.Server2 as Server import Ouroboros.Network.Snocket (Snocket, TestAddress (..), socketSnocket) @@ -126,12 +120,18 @@ import Ouroboros.Network.Testing.Utils (WithName (..), WithTime (..), genDelayWithPrecision, sayTracer, tracerWithTime, nightlyTest) -import Test.Ouroboros.Network.ConnectionManager - (allValidTransitionsNames, validTransitionMap, - verifyAbstractTransition) import Test.Ouroboros.Network.Orphans () import Test.Simulation.Network.Snocket hiding (tests) +import TestLib.Utils +import TestLib.ConnectionManager + (verifyAbstractTransition, validTransitionMap, + allValidTransitionsNames, verifyAbstractTransitionOrder, abstractStateIsFinalTransition) +import TestLib.InboundGovernor + (verifyRemoteTransition, validRemoteTransitionMap, + allValidRemoteTransitionsNames, verifyRemoteTransitionOrder, + remoteStrIsFinalTransition) + tests :: TestTree tests = testGroup "Ouroboros.Network" @@ -1409,20 +1409,6 @@ instance Arbitrary req => shrinkEvent (ShutdownClientServer d a) = shrinkDelay d <&> \ d' -> ShutdownClientServer d' a - --- | The concrete address type used by simulations. --- -type SimAddr = Snocket.TestAddress SimAddr_ -type SimAddr_ = Int - --- | We use a wrapper for test addresses since the Arbitrary instance for Snocket.TestAddress only --- generates addresses between 1 and 4. -newtype TestAddr = TestAddr { unTestAddr :: SimAddr } - deriving (Show, Eq, Ord) - -instance Arbitrary TestAddr where - arbitrary = TestAddr . Snocket.TestAddress <$> choose (1, 100) - -- | Each node in the multi-node experiment is controlled by a thread responding to these messages. data ConnectionHandlerMessage peerAddr req = NewConnection peerAddr @@ -1743,335 +1729,12 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer cmTracer , remoteAddress = remoteAddr } --- | Test property together with classification. --- -data TestProperty = TestProperty { - tpProperty :: !Property, - -- ^ 'True' if property is true - - tpNumberOfTransitions :: !(Sum Int), - -- ^ number of all transitions - - tpNumberOfConnections :: !(Sum Int), - -- ^ number of all connections - - tpNumberOfPrunings :: !(Sum Int), - -- ^ number of all connections - - -- - -- classification of connections - -- - tpNegotiatedDataFlows :: ![NegotiatedDataFlow], - tpEffectiveDataFlows :: ![EffectiveDataFlow], - tpTerminationTypes :: ![TerminationType], - tpActivityTypes :: ![ActivityType], - - tpTransitions :: ![AbstractTransition] - - } - -instance Show TestProperty where - show tp = - concat [ "TestProperty " - , "{ tpNumberOfTransitions = " ++ show (tpNumberOfTransitions tp) - , ", tpNumberOfConnections = " ++ show (tpNumberOfConnections tp) - , ", tpNumberOfPrunings = " ++ show (tpNumberOfPrunings tp) - , ", tpNegotiatedDataFlows = " ++ show (tpNegotiatedDataFlows tp) - , ", tpTerminationTypes = " ++ show (tpTerminationTypes tp) - , ", tpActivityTypes = " ++ show (tpActivityTypes tp) - , ", tpTransitions = " ++ show (tpTransitions tp) - , "}" - ] - -instance Semigroup TestProperty where - (<>) (TestProperty a0 a1 a2 a3 a4 a5 a6 a7 a8) - (TestProperty b0 b1 b2 b3 b4 b5 b6 b7 b8) = - TestProperty (a0 .&&. b0) - (a1 <> b1) - (a2 <> b2) - (a3 <> b3) - (a4 <> b4) - (a5 <> b5) - (a6 <> b6) - (a7 <> b7) - (a8 <> b8) - -instance Monoid TestProperty where - mempty = TestProperty (property True) - mempty mempty mempty mempty - mempty mempty mempty mempty - -mkProperty :: TestProperty -> Property -mkProperty TestProperty { tpProperty - , tpNumberOfTransitions = Sum numberOfTransitions_ - , tpNumberOfConnections = Sum numberOfConnections_ - , tpNumberOfPrunings = Sum numberOfPrunings_ - , tpNegotiatedDataFlows - , tpEffectiveDataFlows - , tpTerminationTypes - , tpActivityTypes - , tpTransitions - } = - label (concat [ "Number of transitions: " - , within_ 10 numberOfTransitions_ - ] - ) - . label (concat [ "Number of connections: " - , show numberOfConnections_ - ] - ) - . tabulate "Pruning" [show numberOfPrunings_] - . tabulate "Negotiated DataFlow" (map show tpNegotiatedDataFlows) - . tabulate "Effective DataFLow" (map show tpEffectiveDataFlows) - . tabulate "Termination" (map show tpTerminationTypes) - . tabulate "Activity Type" (map show tpActivityTypes) - . tabulate "Transitions" (map ppTransition tpTransitions) - $ tpProperty - -mkPropertyPruning :: TestProperty -> Property -mkPropertyPruning tp@TestProperty { tpNumberOfPrunings = Sum numberOfPrunings_ } = - cover 35 (numberOfPrunings_ > 0) "Prunings" - . mkProperty - $ tp - -newtype AllProperty = AllProperty { getAllProperty :: Property } - -instance Semigroup AllProperty where - AllProperty a <> AllProperty b = AllProperty (a .&&. b) - -instance Monoid AllProperty where - mempty = AllProperty (property True) - -newtype ArbDataFlow = ArbDataFlow DataFlow - deriving Show - -instance Arbitrary ArbDataFlow where - arbitrary = ArbDataFlow <$> frequency [ (3, pure Duplex) - , (1, pure Unidirectional) - ] - shrink (ArbDataFlow Duplex) = [ArbDataFlow Unidirectional] - shrink (ArbDataFlow Unidirectional) = [] - -data ActivityType - = IdleConn - - -- | Active connections are once that reach any of the state: - -- - -- - 'InboundSt' - -- - 'OutobundUniSt' - -- - 'OutboundDupSt' - -- - 'DuplexSt' - -- - | ActiveConn - deriving (Eq, Show) - -data TerminationType - = ErroredTermination - | CleanTermination - deriving (Eq, Show) - -data NegotiatedDataFlow - = NotNegotiated - - -- | Negotiated value of 'DataFlow' - | NegotiatedDataFlow DataFlow - deriving (Eq, Show) - -data EffectiveDataFlow - -- | Unlike the negotiated 'DataFlow' this indicates if the connection has - -- ever been in 'DuplexSt' - -- - = EffectiveDataFlow DataFlow - deriving (Eq, Show) - - --- | Pattern synonym which matches either 'RemoteHotEst' or 'RemoteWarmSt'. --- -pattern RemoteEstSt :: RemoteSt -pattern RemoteEstSt <- (( \ case - RemoteHotSt -> True - RemoteWarmSt -> True - _ -> False - ) -> True - ) - -{-# COMPLETE RemoteEstSt, RemoteIdleSt, RemoteColdSt #-} - - --- | Specification of the transition table of the inbound governor. --- -verifyRemoteTransition :: RemoteTransition -> Bool -verifyRemoteTransition Transition {fromState, toState} = - case (fromState, toState) of - -- The initial state must be 'RemoteIdleSt'. - (Nothing, Just RemoteIdleSt) -> True - - -- - -- Promotions - -- - - (Just RemoteIdleSt, Just RemoteEstSt) -> True - (Just RemoteColdSt, Just RemoteEstSt) -> True - (Just RemoteWarmSt, Just RemoteHotSt) -> True - - -- - -- Demotions - -- - - (Just RemoteHotSt, Just RemoteWarmSt) -> True - -- demotion to idle state can happen from any established state - (Just RemoteEstSt, Just RemoteIdleSt) -> True - -- demotion to cold can only be done from idle state; We explicitly rule - -- out demotions to cold from warm or hot states. - (Just RemoteEstSt, Just RemoteColdSt) -> False - (Just RemoteIdleSt, Just RemoteColdSt) -> True - -- normal termination (if outbound side is not using that connection) - (Just RemoteIdleSt, Nothing) -> True - -- This transition corresponds to connection manager's: - -- @ - -- Commit^{Duplex}_{Local} : OutboundIdleState Duplex - -- → TerminatingState - -- @ - (Just RemoteColdSt, Nothing) -> True - -- any of the mini-protocols errored - (Just RemoteEstSt, Nothing) -> True - - -- - -- We are conservative to name all the identity transitions. - -- - - -- This might happen if starting any of the responders errored. - (Nothing, Nothing) -> True - -- @RemoteWarmSt → RemoteWarmSt@, @RemoteIdleSt → RemoteIdleSt@ and - -- @RemoteColdSt → RemoteColdSt@ transition are observed if a hot or - -- warm protocol terminates (which triggers @RemoteEstSt -> RemoteWarmSt@) - (Just RemoteWarmSt, Just RemoteWarmSt) -> True - (Just RemoteIdleSt, Just RemoteIdleSt) -> True - (Just RemoteColdSt, Just RemoteColdSt) -> True - - (_, _) -> False - - - --- | Maps each valid remote transition into one number. Collapses all invalid --- transition into a single number. --- --- NOTE: Should be in sync with 'verifyRemoteTransition' --- -validRemoteTransitionMap :: RemoteTransition -> (Int, String) -validRemoteTransitionMap t@Transition { fromState, toState } = - case (fromState, toState) of - (Nothing , Just RemoteIdleSt) -> (00, show t) - (Just RemoteIdleSt, Just RemoteEstSt) -> (01, show t) - (Just RemoteColdSt, Just RemoteEstSt) -> (02, show t) - (Just RemoteWarmSt, Just RemoteHotSt) -> (03, show t) - (Just RemoteHotSt , Just RemoteWarmSt) -> (04, show t) - (Just RemoteEstSt , Just RemoteIdleSt) -> (05, show t) - (Just RemoteIdleSt, Just RemoteColdSt) -> (06, show t) - (Just RemoteIdleSt, Nothing) -> (07, show t) - (Just RemoteColdSt, Nothing) -> (08, show t) - (Just RemoteEstSt , Nothing) -> (09, show t) - (Nothing , Nothing) -> (10, show t) - (Just RemoteWarmSt, Just RemoteWarmSt) -> (11, show t) - (Just RemoteIdleSt, Just RemoteIdleSt) -> (12, show t) - (Just RemoteColdSt, Just RemoteColdSt) -> (13, show t) - (_ , _) -> (99, show t) - --- | List of all valid transition's names. --- --- NOTE: Should be in sync with 'verifyAbstractTransition'. --- -allValidRemoteTransitionsNames :: [String] -allValidRemoteTransitionsNames = - map show - [ Transition Nothing (Just RemoteIdleSt) - , Transition (Just RemoteIdleSt) (Just RemoteWarmSt) - -- , Transition (Just RemoteIdleSt) (Just RemoteHotSt) - -- , Transition (Just RemoteColdSt) (Just RemoteWarmSt) - -- , Transition (Just RemoteColdSt) (Just RemoteHotSt) - , Transition (Just RemoteWarmSt) (Just RemoteHotSt) - , Transition (Just RemoteHotSt ) (Just RemoteWarmSt) - , Transition (Just RemoteWarmSt) (Just RemoteIdleSt) - -- , Transition (Just RemoteHotSt) (Just RemoteIdleSt) - , Transition (Just RemoteIdleSt) (Just RemoteColdSt) - , Transition (Just RemoteIdleSt) Nothing - , Transition (Just RemoteColdSt) Nothing - , Transition (Just RemoteWarmSt) Nothing - , Transition (Just RemoteHotSt) Nothing - , Transition Nothing Nothing - -- , Transition (Just RemoteWarmSt) (Just RemoteWarmSt) - -- , Transition (Just RemoteIdleSt) (Just RemoteIdleSt) - -- , Transition (Just RemoteColdSt) (Just RemoteColdSt) - ] - data Three a b c = First a | Second b | Third c deriving Show - --- 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', and since we - -- assume that all transitions are valid we do not have to check the - -- 'fromState'. - go [] (Transition _ UnknownConnectionSt) = mempty - go [] tr@(Transition _ _) = - AllProperty - $ counterexample - ("\nUnexpected last transition: " ++ show tr) - (property False) - -- 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 - --- 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. -verifyRemoteTransitionOrder :: [RemoteTransition] - -> AllProperty -verifyRemoteTransitionOrder [] = mempty -verifyRemoteTransitionOrder (h:t) = go t h - where - go :: [RemoteTransition] -> RemoteTransition -> AllProperty - -- All transitions must end in the 'Nothing' (final) state, and since - -- we assume all transitions are valid we do not have to check the - -- 'fromState' . - go [] (Transition _ Nothing) = mempty - go [] tr@(Transition _ _) = - AllProperty - $ counterexample - ("\nUnexpected last transition: " ++ show tr) - (property False) - -- 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 - - validate_transitions :: MultiNodeScript Int TestAddr -> SimTrace () -> Property @@ -2114,7 +1777,7 @@ validate_transitions mns@(MultiNodeScript events _) trace = } ) . fmap (map ttTransition) - . splitConns id + . groupConns id abstractStateIsFinalTransition $ abstractTransitionEvents where abstractTransitionEvents :: Trace (SimResult ()) @@ -2289,9 +1952,9 @@ prop_connection_manager_valid_transition_order serverAcc (ArbDataFlow dataFlow) MainReturn {} -> mempty _ -> AllProperty (property False) ) - verifyAbstractTransitionOrder + (verifyAbstractTransitionOrder True) . fmap (map ttTransition) - . splitConns id + . groupConns id abstractStateIsFinalTransition $ abstractTransitionEvents where sim :: IOSim s () @@ -2329,9 +1992,9 @@ prop_connection_manager_valid_transition_order_racy serverAcc (ArbDataFlow dataF MainReturn {} -> mempty _ -> AllProperty (property False) ) - verifyAbstractTransitionOrder + (verifyAbstractTransitionOrder True) . fmap (map ttTransition) - . splitConns id + . groupConns id abstractStateIsFinalTransition $ abstractTransitionEvents where sim :: IOSim s () @@ -2573,7 +2236,7 @@ prop_timeouts_enforced serverAcc (ArbDataFlow dataFlow) transitionSignal :: Trace (SimResult ()) [(Time, AbstractTransitionTrace SimAddr)] transitionSignal = fmap (map ((,) <$> wtTime <*> wtEvent)) - . splitConns wtEvent + . groupConns wtEvent abstractStateIsFinalTransition . withTimeNameTraceEvents $ trace @@ -3036,7 +2699,8 @@ prop_inbound_governor_valid_transition_order serverAcc (ArbDataFlow dataFlow) _ -> AllProperty (property False) ) verifyRemoteTransitionOrder - . splitRemoteConns + . fmap (map ttTransition) + . groupConns id remoteStrIsFinalTransition $ remoteTransitionTraceEvents where sim :: IOSim s () @@ -3212,7 +2876,7 @@ prop_connection_manager_pruning serverAcc } ) . fmap (map ttTransition) - . splitConns id + . groupConns id abstractStateIsFinalTransition $ abstractTransitionEvents where sim :: IOSim s () @@ -3601,73 +3265,6 @@ unit_connection_terminated_when_negotiating = 0 arbDataFlow absBearerInfo multiNodeScript - --- | Split 'AbstractTransitionTrace' into separate connections. This relies on --- the property that every connection is terminated with 'UnknownConnectionSt'. --- This property is verified by 'verifyAbstractTransitionOrder'. --- -splitConns :: (a -> AbstractTransitionTrace SimAddr) - -> Trace (SimResult ()) a - -> Trace (SimResult ()) [a] -splitConns getTransition = - 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 a -> - let TransitionTrace { ttPeerAddr, ttTransition } = getTransition a - in case ttTransition of - Transition _ UnknownConnectionSt -> - case ttPeerAddr `Map.lookup` s of - Nothing -> ( Map.insert ttPeerAddr [a] s - , Nothing - ) - Just trs -> ( Map.delete ttPeerAddr s - , Just (reverse $ a : trs) - ) - _ -> ( Map.alter ( \ case - Nothing -> Just [a] - Just as -> Just (a : as) - ) ttPeerAddr s - , Nothing - ) - ) - Map.empty - -splitRemoteConns :: Trace (SimResult ()) (RemoteTransitionTrace SimAddr) - -> Trace (SimResult ()) [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 - -ppTransition :: AbstractTransition -> String -ppTransition Transition {fromState, toState} = - printf "%-30s → %s" (show fromState) (show toState) - ppScript :: (Show peerAddr, Show req) => MultiNodeScript peerAddr req -> String ppScript (MultiNodeScript script _) = intercalate "\n" $ go 0 script where @@ -3748,70 +3345,6 @@ showConnectionEvents (CloseOutboundConnection{}) = "CloseOutboundConnection" showConnectionEvents (ShutdownClientServer{}) = "ShutdownClientServer" --- classify negotiated data flow -classifyPrunings :: [ConnectionManagerTrace SimAddr (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)] -> Sum Int -classifyPrunings = - Sum - . length - . filter ( \ tr - -> case tr of - x -> case x of - TrPruneConnections _ _ _ -> True - _ -> False - ) - --- classify negotiated data flow -classifyNegotiatedDataFlow :: [AbstractTransition] -> NegotiatedDataFlow -classifyNegotiatedDataFlow as = - case find ( \ tr - -> case toState tr of - OutboundUniSt -> True - OutboundDupSt {} -> True - InboundIdleSt {} -> True - _ -> False - ) as of - Nothing -> NotNegotiated - Just tr -> - case toState tr of - OutboundUniSt -> NegotiatedDataFlow Unidirectional - OutboundDupSt {} -> NegotiatedDataFlow Duplex - (InboundIdleSt df) -> NegotiatedDataFlow df - _ -> error "impossible happened!" - --- classify effective data flow -classifyEffectiveDataFlow :: [AbstractTransition] -> EffectiveDataFlow -classifyEffectiveDataFlow as = - case find ((== DuplexSt) . toState) as of - Nothing -> EffectiveDataFlow Unidirectional - Just _ -> EffectiveDataFlow Duplex - --- classify termination -classifyTermination :: [AbstractTransition] -> TerminationType -classifyTermination as = - case last $ dropWhileEnd - (== (Transition TerminatedSt TerminatedSt)) - $ dropWhileEnd - (== (Transition TerminatedSt UnknownConnectionSt)) - $ as of - Transition { fromState = TerminatingSt - , toState = TerminatedSt - } -> CleanTermination - _ -> ErroredTermination - --- classify if a connection is active or not -classifyActivityType :: [AbstractTransition] -> ActivityType -classifyActivityType as = - case find ( \ tr - -> case toState tr of - InboundSt {} -> True - OutboundUniSt -> True - OutboundDupSt {} -> True - DuplexSt {} -> True - _ -> False - ) as of - Nothing -> IdleConn - Just {} -> ActiveConn - -- | Redefine this tracer to get valuable tracing information from various -- components: -- @@ -3869,12 +3402,3 @@ prettyPrintTrace tr = concat , "\n" ] -within_ :: Int -> Int -> String -within_ _ 0 = "0" -within_ a b = let x = b `div` a in - concat [ if b < a - then "1" - else show $ x * a - , " - " - , show $ x * a + a - 1 - ] diff --git a/ouroboros-network-framework/testlib/TestLib/ConnectionManager.hs b/ouroboros-network-framework/testlib/TestLib/ConnectionManager.hs new file mode 100644 index 00000000000..c371b5fab22 --- /dev/null +++ b/ouroboros-network-framework/testlib/TestLib/ConnectionManager.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module TestLib.ConnectionManager where + +import Prelude hiding (read) + +import Ouroboros.Network.ConnectionManager.Types + +import Test.QuickCheck (counterexample, property) + +import TestLib.Utils + +verifyAbstractTransition :: AbstractTransition + -> Bool +verifyAbstractTransition Transition { fromState, toState } = + case (fromState, toState) of + -- + -- Outbound + -- + + -- @Reserve@ + (TerminatedSt, ReservedOutboundSt) -> True + (UnknownConnectionSt, ReservedOutboundSt) -> True + -- @Connected@ + (ReservedOutboundSt, UnnegotiatedSt Outbound) -> True + -- @Negotiated^{Unidirectional}_{Outbound}@ + (UnnegotiatedSt Outbound, OutboundUniSt) -> True + -- @Negotiated^{Duplex}_{Outbound}@ + (UnnegotiatedSt Outbound, OutboundDupSt Ticking) -> True + (UnnegotiatedSt _, TerminatingSt) -> True + + -- @DemotedToCold^{Unidirectional}_{Local}@ + (OutboundUniSt, OutboundIdleSt Unidirectional) -> True + -- @TimeoutExpired@ + (OutboundDupSt Ticking, OutboundDupSt Expired) -> True + -- @DemotedToCold^{Duplex}_{Local}@ + (OutboundDupSt Expired, OutboundIdleSt Duplex) -> True + -- identity transition executed by 'demotedToColdRemote' + (OutboundIdleSt dataFlow, OutboundIdleSt dataFlow') -> dataFlow == dataFlow' + + -- + -- Outbound ↔ Inbound + -- + + -- @DemotedToCold^{Duplex}_{Local}@ + (OutboundDupSt Ticking, InboundIdleSt Duplex) -> True + -- @Awake^{Duplex}_{Local} + (InboundIdleSt Duplex, OutboundDupSt Ticking) -> True + -- @PromotedToWarm^{Duplex}_{Remote}@ + (OutboundDupSt Ticking, DuplexSt) -> True + (OutboundDupSt Expired, DuplexSt) -> True + -- can be executed by 'demotedToColdRemote' + (OutboundDupSt expired, OutboundDupSt expired') + -> expired == expired' + -- @PromotedToWarm^{Duplex}_{Local}@ + (InboundSt Duplex, DuplexSt) -> True + -- @DemotedToCold^{Duplex}_{Remote}@ + (DuplexSt, OutboundDupSt Ticking) -> True + -- @DemotedToCold^{Duplex}_{Local}@ + (DuplexSt, InboundSt Duplex) -> True + + -- + -- Inbound + -- + + -- @Accepted@ + (TerminatedSt, UnnegotiatedSt Inbound) -> True + (UnknownConnectionSt, UnnegotiatedSt Inbound) -> True + -- @Overwritten@ + (ReservedOutboundSt, UnnegotiatedSt Inbound) -> True + -- @Negotiated^{Duplex}_{Inbound} + (UnnegotiatedSt Inbound, InboundIdleSt Duplex) -> True + -- @Negotiated^{Unidirectional}_{Inbound} + (UnnegotiatedSt Inbound, InboundIdleSt Unidirectional) -> True + + -- 'unregisterOutboundConnection' and 'demotedToColdRemote' might perfrom + (InboundIdleSt Duplex, InboundIdleSt Duplex) -> True + -- @Awake^{Duplex}_{Remote} + (InboundIdleSt Duplex, InboundSt Duplex) -> True + -- @Commit^{Duplex} + (InboundIdleSt Duplex, TerminatingSt) -> True + -- @DemotedToCold^{Duplex}_{Local} + (InboundSt Duplex, InboundIdleSt Duplex) -> True + + -- @Awake^{Unidirectional}_{Remote} + (InboundIdleSt Unidirectional, InboundSt Unidirectional) -> True + -- @Commit^{Unidirectional} + (InboundIdleSt Unidirectional, TerminatingSt) -> True + -- @DemotedToCold^{Unidirectional}_{Local} + (InboundSt Unidirectional, InboundIdleSt Unidirectional) -> True + + -- + -- OutboundIdleSt + -- + + (OutboundIdleSt Duplex, InboundSt Duplex) -> True + (OutboundIdleSt _dataFlow, TerminatingSt) -> True + + -- + -- Terminate + -- + + -- @Terminate@ + (TerminatingSt, TerminatedSt) -> True + + -- explicit prohibition of reflexive terminate transition + (TerminatedSt, TerminatedSt) -> False + -- implicit terminate transition + (_, TerminatedSt) -> True + + -- explicit prohibition of reflexive unknown transition + (UnknownConnectionSt, UnknownConnectionSt) -> False + (_, UnknownConnectionSt) -> True + + -- We accept connection in 'TerminatingSt' + (TerminatingSt, UnnegotiatedSt Inbound) -> True + + _ -> False + +-- | Maps each valid transition into one number. Collapses all invalid transition into a +-- single number. +-- +-- NOTE: Should be in sync with 'verifyAbstractTransition' +-- +validTransitionMap :: AbstractTransition + -> (Int, String) +validTransitionMap t@Transition { fromState, toState } = + case (fromState, toState) of + (TerminatedSt , ReservedOutboundSt) -> (01, show t) + (UnknownConnectionSt , ReservedOutboundSt) -> (02, show t) + (ReservedOutboundSt , UnnegotiatedSt Outbound) -> (03, show t) + (UnnegotiatedSt Outbound , OutboundUniSt) -> (04, show t) + (UnnegotiatedSt Outbound , OutboundDupSt Ticking) -> (05, show t) + (OutboundUniSt , OutboundIdleSt Unidirectional) -> (06, show t) + (OutboundDupSt Ticking , OutboundDupSt Expired) -> (07, show t) + (OutboundDupSt Expired , OutboundIdleSt Duplex) -> (08, show t) + (OutboundIdleSt dataFlow , OutboundIdleSt dataFlow') + | dataFlow == dataFlow' -> (09, show t) + (OutboundDupSt Ticking , InboundIdleSt Duplex) -> (10, show t) + (InboundIdleSt Duplex , OutboundDupSt Ticking) -> (11, show t) + (OutboundDupSt Ticking , DuplexSt) -> (12, show t) + (OutboundDupSt Expired , DuplexSt) -> (13, show t) + (OutboundDupSt expired , OutboundDupSt expired') + | expired == expired' -> (14, show t) + (InboundSt Duplex , DuplexSt) -> (15, show t) + (DuplexSt , OutboundDupSt Ticking) -> (16, show t) + (DuplexSt , InboundSt Duplex) -> (17, show t) + (TerminatedSt , UnnegotiatedSt Inbound) -> (18, show t) + (UnknownConnectionSt , UnnegotiatedSt Inbound) -> (19, show t) + (ReservedOutboundSt , UnnegotiatedSt Inbound) -> (20, show t) + (UnnegotiatedSt Inbound , InboundIdleSt Duplex) -> (21, show t) + (UnnegotiatedSt Inbound , InboundIdleSt Unidirectional) -> (22, show t) + (InboundIdleSt Duplex , InboundIdleSt Duplex) -> (23, show t) + (InboundIdleSt Duplex , InboundSt Duplex) -> (24, show t) + (InboundIdleSt Duplex , TerminatingSt) -> (25, show t) + (InboundSt Duplex , InboundIdleSt Duplex) -> (26, show t) + (InboundIdleSt Unidirectional , InboundSt Unidirectional) -> (27, show t) + (InboundIdleSt Unidirectional , TerminatingSt) -> (28, show t) + (InboundSt Unidirectional , InboundIdleSt Unidirectional) -> (29, show t) + (OutboundIdleSt Duplex , InboundSt Duplex) -> (30, show t) + (OutboundIdleSt _dataFlow , TerminatingSt) -> (31, show t) + (TerminatingSt , TerminatedSt) -> (32, show t) + (_ , TerminatedSt) -> (33, show t) + (_ , UnknownConnectionSt) -> (34, show t) + (TerminatingSt , UnnegotiatedSt Inbound) -> (35, show t) + _ -> (99, show t) + +-- 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 :: Bool -- ^ Check last transition: useful for + -- distinguish Diffusion layer tests + -- vs non-Diffusion ones. + -> [AbstractTransition] + -> AllProperty +verifyAbstractTransitionOrder _ [] = mempty +verifyAbstractTransitionOrder checkLast (h:t) = go t h + where + go :: [AbstractTransition] -> AbstractTransition -> AllProperty + -- All transitions must end in the 'UnknownConnectionSt', and since we + -- assume that all transitions are valid we do not have to check the + -- 'fromState'. + go [] (Transition _ UnknownConnectionSt) = mempty + go [] tr@(Transition _ _) = + AllProperty + $ counterexample + ("\nUnexpected last transition: " ++ show tr) + (property (not checkLast)) + -- 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 + + +-- | List of all valid transition's names. +-- +-- NOTE: Should be in sync with 'verifyAbstractTransition', but due to #3516 +-- abrupt terminating transitions and identity transitions are trimmed for now, +-- until we tweak the generators to include more connection errors. +-- +allValidTransitionsNames :: [String] +allValidTransitionsNames = + map show + [ Transition UnknownConnectionSt ReservedOutboundSt + -- , Transition TerminatedSt ReservedOutboundSt + , Transition ReservedOutboundSt (UnnegotiatedSt Outbound) + , Transition (UnnegotiatedSt Outbound) OutboundUniSt + , Transition (UnnegotiatedSt Outbound) (OutboundDupSt Ticking) + , Transition OutboundUniSt (OutboundIdleSt Unidirectional) + , Transition (OutboundDupSt Ticking) (OutboundDupSt Expired) + -- , Transition (OutboundDupSt Expired) (OutboundIdleSt Duplex) + -- , Transition (OutboundIdleSt Unidirectional) (OutboundIdleSt Unidirectional) + -- , Transition (OutboundIdleSt Duplex) (OutboundIdleSt Duplex) + , Transition (OutboundDupSt Ticking) (InboundIdleSt Duplex) + , Transition (InboundIdleSt Duplex) (OutboundDupSt Ticking) + , Transition (OutboundDupSt Ticking) DuplexSt + -- , Transition (OutboundDupSt Expired) DuplexSt + -- , Transition (OutboundDupSt Ticking) (OutboundDupSt Ticking) + -- , Transition (OutboundDupSt Expired) (OutboundDupSt Expired) + , Transition (InboundSt Duplex) DuplexSt + , Transition DuplexSt (OutboundDupSt Ticking) + , Transition DuplexSt (InboundSt Duplex) + -- , Transition TerminatedSt (UnnegotiatedSt Inbound) + , Transition UnknownConnectionSt (UnnegotiatedSt Inbound) + , Transition ReservedOutboundSt (UnnegotiatedSt Inbound) + , Transition (UnnegotiatedSt Inbound) (InboundIdleSt Duplex) + , Transition (UnnegotiatedSt Inbound) (InboundIdleSt Unidirectional) + -- , Transition (InboundIdleSt Duplex) (InboundIdleSt Duplex) + , Transition (InboundIdleSt Duplex) (InboundSt Duplex) + -- , Transition (InboundIdleSt Duplex) TerminatingSt + -- , Transition (InboundSt Duplex) (InboundIdleSt Duplex) + -- , Transition (InboundIdleSt Unidirectional) (InboundSt Unidirectional) + -- , Transition (InboundIdleSt Unidirectional) TerminatingSt + -- , Transition (InboundSt Unidirectional) (InboundIdleSt Unidirectional) + -- , Transition (OutboundIdleSt Duplex) (InboundSt Duplex) + -- , Transition (OutboundIdleSt Unidirectional) TerminatingSt + -- , Transition (OutboundIdleSt Duplex) TerminatingSt + , Transition TerminatingSt TerminatedSt + -- , Transition TerminatedSt UnknownConnectionSt + -- , Transition TerminatingSt (UnnegotiatedSt Inbound) + -- , Transition (_) (TerminatedSt) + -- , Transition (_) (UnknownConnectionSt) + ] + +abstractStateIsFinalTransition :: Transition' AbstractState -> Bool +abstractStateIsFinalTransition (Transition _ UnknownConnectionSt) = True +abstractStateIsFinalTransition _ = False diff --git a/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs b/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs new file mode 100644 index 00000000000..5c7d76ef654 --- /dev/null +++ b/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +module TestLib.InboundGovernor where + +import Test.QuickCheck + +import Ouroboros.Network.ConnectionManager.Types +import Ouroboros.Network.InboundGovernor (RemoteSt (..)) +import Ouroboros.Network.Server2 (RemoteTransition) + +import TestLib.Utils + +-- | Pattern synonym which matches either 'RemoteHotEst' or 'RemoteWarmSt'. +-- +pattern RemoteEstSt :: RemoteSt +pattern RemoteEstSt <- (\ case + RemoteHotSt -> True + RemoteWarmSt -> True + _ -> False -> True + ) + +{-# COMPLETE RemoteEstSt, RemoteIdleSt, RemoteColdSt #-} + + +-- | Specification of the transition table of the inbound governor. +-- +verifyRemoteTransition :: RemoteTransition -> Bool +verifyRemoteTransition Transition {fromState, toState} = + case (fromState, toState) of + -- The initial state must be 'RemoteIdleSt'. + (Nothing, Just RemoteIdleSt) -> True + + -- + -- Promotions + -- + + (Just RemoteIdleSt, Just RemoteEstSt) -> True + (Just RemoteColdSt, Just RemoteEstSt) -> True + (Just RemoteWarmSt, Just RemoteHotSt) -> True + + -- + -- Demotions + -- + + (Just RemoteHotSt, Just RemoteWarmSt) -> True + -- demotion to idle state can happen from any established state + (Just RemoteEstSt, Just RemoteIdleSt) -> True + -- demotion to cold can only be done from idle state; We explicitly rule + -- out demotions to cold from warm or hot states. + (Just RemoteEstSt, Just RemoteColdSt) -> False + (Just RemoteIdleSt, Just RemoteColdSt) -> True + -- normal termination (if outbound side is not using that connection) + (Just RemoteIdleSt, Nothing) -> True + -- This transition corresponds to connection manager's: + -- @ + -- Commit^{Duplex}_{Local} : OutboundIdleState Duplex + -- → TerminatingState + -- @ + (Just RemoteColdSt, Nothing) -> True + -- any of the mini-protocols errored + (Just RemoteEstSt, Nothing) -> True + + -- + -- We are conservative to name all the identity transitions. + -- + + -- This might happen if starting any of the responders errored. + (Nothing, Nothing) -> True + -- @RemoteWarmSt → RemoteWarmSt@, @RemoteIdleSt → RemoteIdleSt@ and + -- @RemoteColdSt → RemoteColdSt@ transition are observed if a hot or + -- warm protocol terminates (which triggers @RemoteEstSt -> RemoteWarmSt@) + (Just RemoteWarmSt, Just RemoteWarmSt) -> True + (Just RemoteIdleSt, Just RemoteIdleSt) -> True + (Just RemoteColdSt, Just RemoteColdSt) -> True + + (_, _) -> False + + + +-- | Maps each valid remote transition into one number. Collapses all invalid +-- transition into a single number. +-- +-- NOTE: Should be in sync with 'verifyRemoteTransition' +-- +validRemoteTransitionMap :: RemoteTransition -> (Int, String) +validRemoteTransitionMap t@Transition { fromState, toState } = + case (fromState, toState) of + (Nothing , Just RemoteIdleSt) -> (00, show t) + (Just RemoteIdleSt, Just RemoteEstSt) -> (01, show t) + (Just RemoteColdSt, Just RemoteEstSt) -> (02, show t) + (Just RemoteWarmSt, Just RemoteHotSt) -> (03, show t) + (Just RemoteHotSt , Just RemoteWarmSt) -> (04, show t) + (Just RemoteEstSt , Just RemoteIdleSt) -> (05, show t) + (Just RemoteIdleSt, Just RemoteColdSt) -> (06, show t) + (Just RemoteIdleSt, Nothing) -> (07, show t) + (Just RemoteColdSt, Nothing) -> (08, show t) + (Just RemoteEstSt , Nothing) -> (09, show t) + (Nothing , Nothing) -> (10, show t) + (Just RemoteWarmSt, Just RemoteWarmSt) -> (11, show t) + (Just RemoteIdleSt, Just RemoteIdleSt) -> (12, show t) + (Just RemoteColdSt, Just RemoteColdSt) -> (13, show t) + (_ , _) -> (99, show t) + +-- | List of all valid transition's names. +-- +-- NOTE: Should be in sync with 'verifyAbstractTransition'. +-- +allValidRemoteTransitionsNames :: [String] +allValidRemoteTransitionsNames = + map show + [ Transition Nothing (Just RemoteIdleSt) + , Transition (Just RemoteIdleSt) (Just RemoteWarmSt) + -- , Transition (Just RemoteIdleSt) (Just RemoteHotSt) + -- , Transition (Just RemoteColdSt) (Just RemoteWarmSt) + -- , Transition (Just RemoteColdSt) (Just RemoteHotSt) + , Transition (Just RemoteWarmSt) (Just RemoteHotSt) + , Transition (Just RemoteHotSt ) (Just RemoteWarmSt) + , Transition (Just RemoteWarmSt) (Just RemoteIdleSt) + -- , Transition (Just RemoteHotSt) (Just RemoteIdleSt) + , Transition (Just RemoteIdleSt) (Just RemoteColdSt) + , Transition (Just RemoteIdleSt) Nothing + , Transition (Just RemoteColdSt) Nothing + , Transition (Just RemoteWarmSt) Nothing + , Transition (Just RemoteHotSt) Nothing + , Transition Nothing Nothing + -- , Transition (Just RemoteWarmSt) (Just RemoteWarmSt) + -- , Transition (Just RemoteIdleSt) (Just RemoteIdleSt) + -- , Transition (Just RemoteColdSt) (Just RemoteColdSt) + ] + +-- 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. +verifyRemoteTransitionOrder :: [RemoteTransition] + -> AllProperty +verifyRemoteTransitionOrder [] = mempty +verifyRemoteTransitionOrder (h:t) = go t h + where + go :: [RemoteTransition] -> RemoteTransition -> AllProperty + -- All transitions must end in the 'Nothing' (final) state, and since + -- we assume all transitions are valid we do not have to check the + -- 'fromState' . + go [] (Transition _ Nothing) = mempty + go [] tr@(Transition _ _) = + AllProperty + $ counterexample + ("\nUnexpected last transition: " ++ show tr) + (property False) + -- 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 + +remoteStrIsFinalTransition :: Transition' (Maybe RemoteSt) -> Bool +remoteStrIsFinalTransition (Transition _ Nothing) = True +remoteStrIsFinalTransition _ = False diff --git a/ouroboros-network-framework/testlib/TestLib/Utils.hs b/ouroboros-network-framework/testlib/TestLib/Utils.hs new file mode 100644 index 00000000000..5b1c51ac194 --- /dev/null +++ b/ouroboros-network-framework/testlib/TestLib/Utils.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} + +module TestLib.Utils where + +import Control.Monad.IOSim + +import Data.Bitraversable (bimapAccumL) +import Data.List (find, dropWhileEnd) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, isJust) +import Data.Monoid (Sum (Sum)) +import qualified Data.List.Trace as Trace + +import Text.Printf (printf) + +import Test.QuickCheck + ((.&&.), Property, property, Arbitrary(..), shrink, + frequency, cover, label, tabulate, choose) + +import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) +import Ouroboros.Network.ConnectionManager.Types +import qualified Ouroboros.Network.Snocket as Snocket + + +-- | Groups 'TransitionTrace' to the same peerAddr. +-- +groupConns :: Ord addr + => (a -> TransitionTrace' addr st) + -> (Transition' st -> Bool) + -> Trace r a + -> Trace r [a] +groupConns getTransition isFinalTransition = + 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 (reverse a)) as) o (Map.elems s)) + . bimapAccumL + ( \ s a -> (s, a)) + ( \ s a -> + let TransitionTrace { ttPeerAddr, ttTransition } = getTransition a + in if isFinalTransition ttTransition + then case ttPeerAddr `Map.lookup` s of + Nothing -> ( Map.insert ttPeerAddr [a] s + , Nothing + ) + Just trs -> ( Map.delete ttPeerAddr s + , Just (reverse $ a : trs) + ) + else ( Map.alter (\case + Nothing -> Just [a] + Just as -> Just (a : as) + ) + ttPeerAddr s + , Nothing) + ) + Map.empty + +-- | The concrete address type used by simulations. +-- +type SimAddr = Snocket.TestAddress SimAddr_ +type SimAddr_ = Int + +-- | We use a wrapper for test addresses since the Arbitrary instance for Snocket.TestAddress only +-- generates addresses between 1 and 4. +newtype TestAddr = TestAddr { unTestAddr :: SimAddr } + deriving (Show, Eq, Ord) + +instance Arbitrary TestAddr where + arbitrary = TestAddr . Snocket.TestAddress <$> choose (1, 100) + + +-- | Test property together with classification. +-- +data TestProperty = TestProperty { + tpProperty :: !Property, + -- ^ 'True' if property is true + + tpNumberOfTransitions :: !(Sum Int), + -- ^ number of all transitions + + tpNumberOfConnections :: !(Sum Int), + -- ^ number of all connections + + tpNumberOfPrunings :: !(Sum Int), + -- ^ number of all connections + + -- + -- classification of connections + -- + tpNegotiatedDataFlows :: ![NegotiatedDataFlow], + tpEffectiveDataFlows :: ![EffectiveDataFlow], + tpTerminationTypes :: ![TerminationType], + tpActivityTypes :: ![ActivityType], + + tpTransitions :: ![AbstractTransition] + + } + +instance Show TestProperty where + show tp = + concat [ "TestProperty " + , "{ tpNumberOfTransitions = " ++ show (tpNumberOfTransitions tp) + , ", tpNumberOfConnections = " ++ show (tpNumberOfConnections tp) + , ", tpNumberOfPrunings = " ++ show (tpNumberOfPrunings tp) + , ", tpNegotiatedDataFlows = " ++ show (tpNegotiatedDataFlows tp) + , ", tpTerminationTypes = " ++ show (tpTerminationTypes tp) + , ", tpActivityTypes = " ++ show (tpActivityTypes tp) + , ", tpTransitions = " ++ show (tpTransitions tp) + , "}" + ] + +instance Semigroup TestProperty where + (<>) (TestProperty a0 a1 a2 a3 a4 a5 a6 a7 a8) + (TestProperty b0 b1 b2 b3 b4 b5 b6 b7 b8) = + TestProperty (a0 .&&. b0) + (a1 <> b1) + (a2 <> b2) + (a3 <> b3) + (a4 <> b4) + (a5 <> b5) + (a6 <> b6) + (a7 <> b7) + (a8 <> b8) + +instance Monoid TestProperty where + mempty = TestProperty (property True) + mempty mempty mempty mempty + mempty mempty mempty mempty + +mkProperty :: TestProperty -> Property +mkProperty TestProperty { tpProperty + , tpNumberOfTransitions = Sum numberOfTransitions_ + , tpNumberOfConnections = Sum numberOfConnections_ + , tpNumberOfPrunings = Sum numberOfPrunings_ + , tpNegotiatedDataFlows + , tpEffectiveDataFlows + , tpTerminationTypes + , tpActivityTypes + , tpTransitions + } = + label ("Number of transitions: " ++ within_ 10 numberOfTransitions_ + ) + . label ("Number of connections: " ++ show numberOfConnections_ + ) + . tabulate "Pruning" [show numberOfPrunings_] + . tabulate "Negotiated DataFlow" (map show tpNegotiatedDataFlows) + . tabulate "Effective DataFLow" (map show tpEffectiveDataFlows) + . tabulate "Termination" (map show tpTerminationTypes) + . tabulate "Activity Type" (map show tpActivityTypes) + . tabulate "Transitions" (map ppTransition tpTransitions) + $ tpProperty + +mkPropertyPruning :: TestProperty -> Property +mkPropertyPruning tp@TestProperty { tpNumberOfPrunings = Sum numberOfPrunings_ } = + cover 35 (numberOfPrunings_ > 0) "Prunings" + . mkProperty + $ tp + +-- classify negotiated data flow +classifyNegotiatedDataFlow :: [AbstractTransition] -> NegotiatedDataFlow +classifyNegotiatedDataFlow as = + case find ( \ tr + -> case toState tr of + OutboundUniSt -> True + OutboundDupSt {} -> True + InboundIdleSt {} -> True + _ -> False + ) as of + Nothing -> NotNegotiated + Just tr -> + case toState tr of + OutboundUniSt -> NegotiatedDataFlow Unidirectional + OutboundDupSt {} -> NegotiatedDataFlow Duplex + (InboundIdleSt df) -> NegotiatedDataFlow df + _ -> error "impossible happened!" + +-- classify effective data flow +classifyEffectiveDataFlow :: [AbstractTransition] -> EffectiveDataFlow +classifyEffectiveDataFlow as = + case find ((== DuplexSt) . toState) as of + Nothing -> EffectiveDataFlow Unidirectional + Just _ -> EffectiveDataFlow Duplex + +-- classify termination +classifyTermination :: [AbstractTransition] -> TerminationType +classifyTermination as = + case last $ dropWhileEnd + (== Transition TerminatedSt TerminatedSt) + $ dropWhileEnd + (== Transition TerminatedSt UnknownConnectionSt) as of + Transition { fromState = TerminatingSt + , toState = TerminatedSt + } -> CleanTermination + _ -> ErroredTermination + +-- classify if a connection is active or not +classifyActivityType :: [AbstractTransition] -> ActivityType +classifyActivityType as = + case find ( \ tr + -> case toState tr of + InboundSt {} -> True + OutboundUniSt -> True + OutboundDupSt {} -> True + DuplexSt {} -> True + _ -> False + ) as of + Nothing -> IdleConn + Just {} -> ActiveConn + +-- classify negotiated data flow +classifyPrunings :: [ConnectionManagerTrace + addr + (ConnectionHandlerTrace + prctl + dataflow)] + -> Sum Int +classifyPrunings = + Sum + . length + . filter ( \x -> case x of + TrPruneConnections _ _ _ -> True + _ -> False + ) + + +newtype AllProperty = AllProperty { getAllProperty :: Property } + +instance Semigroup AllProperty where + AllProperty a <> AllProperty b = AllProperty (a .&&. b) + +instance Monoid AllProperty where + mempty = AllProperty (property True) + +newtype ArbDataFlow = ArbDataFlow DataFlow + deriving Show + +instance Arbitrary ArbDataFlow where + arbitrary = ArbDataFlow <$> frequency [ (3, pure Duplex) + , (1, pure Unidirectional) + ] + shrink (ArbDataFlow Duplex) = [ArbDataFlow Unidirectional] + shrink (ArbDataFlow Unidirectional) = [] + +data ActivityType + = IdleConn + + -- | Active connections are once that reach any of the state: + -- + -- - 'InboundSt' + -- - 'OutobundUniSt' + -- - 'OutboundDupSt' + -- - 'DuplexSt' + -- + | ActiveConn + deriving (Eq, Show) + +data TerminationType + = ErroredTermination + | CleanTermination + deriving (Eq, Show) + +data NegotiatedDataFlow + = NotNegotiated + + -- | Negotiated value of 'DataFlow' + | NegotiatedDataFlow DataFlow + deriving (Eq, Show) + +data EffectiveDataFlow + -- | Unlike the negotiated 'DataFlow' this indicates if the connection has + -- ever been in 'DuplexSt' + -- + = EffectiveDataFlow DataFlow + deriving (Eq, Show) + +within_ :: Int -> Int -> String +within_ _ 0 = "0" +within_ a b = let x = b `div` a in + concat [ if b < a + then "1" + else show $ x * a + , " - " + , show $ x * a + a - 1 + ] + +ppTransition :: AbstractTransition -> String +ppTransition Transition {fromState, toState} = + printf "%-30s → %s" (show fromState) (show toState) + + From dc398c50135b487a55dab84e843824f9f75fc48f Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Mon, 21 Feb 2022 11:59:07 +0000 Subject: [PATCH 2/8] Fixes #3627 --- .../src/Simulation/Network/Snocket.hs | 26 ++++++++++++++++--- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs index 2de4122acd0..03cf3d9ee78 100644 --- a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs @@ -771,10 +771,28 @@ mkSnocket state tr = Snocket { getLocalAddr (Just remoteAddress) (STBearerInfo bearerInfo)) -- connection delay - unmask (threadDelay (biConnectionDelay bearerInfo `min` connectTimeout)) - `onException` - atomically (modifyTVar (nsConnections state) - (Map.delete $ normaliseId connId)) + -- + -- We need a way for a node to detect if the other end failed so + -- we keep an eye on the network state while waiting the full amount + -- of connection delay + connDelayTimeoutVar <- + registerDelay (biConnectionDelay bearerInfo `min` connectTimeout) + unmask + (atomically $ runFirstToFinish $ + FirstToFinish + (LazySTM.readTVar connDelayTimeoutVar >>= check) + <> + FirstToFinish (do + b <- not . Map.member (normaliseId connId) + <$> readTVar (nsConnections state) + check b + throwSTM $ connectIOError connId + $ "unknown connection: " + ++ show (normaliseId connId)) + ) + `onException` + atomically (modifyTVar (nsConnections state) + (Map.delete (normaliseId connId))) when (biConnectionDelay bearerInfo >= connectTimeout) $ do traceWith' fd (STConnectTimeout WaitingToConnect) From 33ec63119fed9d8e2692877f992d8d37fe13ab92 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Wed, 20 Apr 2022 16:15:36 +0100 Subject: [PATCH 3/8] Added CM Valid transition test --- .../src/Simulation/Network/Snocket.hs | 2 +- ouroboros-network/ouroboros-network.cabal | 3 +- .../test/Test/Ouroboros/Network/Testnet.hs | 151 +++++++++++++++++- .../Network/Testnet/Simulation/Node.hs | 15 +- 4 files changed, 161 insertions(+), 10 deletions(-) diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs index 03cf3d9ee78..95ca905e949 100644 --- a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -775,6 +774,7 @@ mkSnocket state tr = Snocket { getLocalAddr -- We need a way for a node to detect if the other end failed so -- we keep an eye on the network state while waiting the full amount -- of connection delay + -- TODO: Improve this see #3628 connDelayTimeoutVar <- registerDelay (biConnectionDelay bearerInfo `min` connectTimeout) unmask diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index b368a01e0cf..1fe9a4bde68 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -1,3 +1,4 @@ +cabal-version: 3.0 name: ouroboros-network version: 0.1.0.0 synopsis: A networking layer for the Ouroboros blockchain protocol @@ -22,7 +23,6 @@ data-files: test-cddl/specs/keep-alive.cddl test-cddl/specs/local-tx-submission.cddl test-cddl/specs/local-state-query.cddl -cabal-version: >=1.10 flag asserts description: Enable assertions @@ -351,6 +351,7 @@ test-suite test network-mux, ouroboros-network, ouroboros-network-framework, + ouroboros-network-framework:testlib, ouroboros-network-testing, ouroboros-protocol-tests, strict-stm, diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index d1224155fea..0b5f77bc3df 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs @@ -10,11 +10,13 @@ import Control.Monad.IOSim.Types (ThreadId) import Control.Monad.Class.MonadTime (Time (Time), diffTime, DiffTime) import Control.Tracer (Tracer (Tracer), contramap, nullTracer) +import Data.Bifoldable (bifoldMap) import Data.Void (Void) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Monoid (Sum(..)) import Data.Dynamic (Typeable) import Data.Functor (void) import Data.List (intercalate) @@ -58,6 +60,13 @@ import Test.QuickCheck (Property, counterexample, conjoin, classify, p import Test.Tasty import Test.Tasty.QuickCheck (testProperty) +import TestLib.Utils (TestProperty(..), mkProperty, ppTransition, + AllProperty (..), classifyNegotiatedDataFlow, + classifyEffectiveDataFlow, classifyTermination, + classifyActivityType, classifyPrunings, groupConns) +import TestLib.ConnectionManager + (verifyAbstractTransition, abstractStateIsFinalTransition) + tests :: TestTree tests = testGroup "Ouroboros.Network.Testnet" @@ -74,6 +83,8 @@ tests = prop_diffusion_target_active_below , testProperty "diffusion target active local above" prop_diffusion_target_active_local_above + , testProperty "diffusion connection manager valid transitions" + prop_diffusion_cm_valid_transitions ] ] @@ -94,6 +105,8 @@ data DiffusionTestTrace = (ConnectionManagerTrace NtNAddr (ConnectionHandlerTrace NtNVersion NtNVersionData)) | DiffusionDiffusionSimulationTrace DiffusionSimulationTrace + | DiffusionConnectionManagerTransitionTrace + (AbstractTransitionTrace NtNAddr) deriving (Show) tracersExtraWithTimeName @@ -140,7 +153,11 @@ tracersExtraWithTimeName ntnAddr = . tracerWithName ntnAddr . tracerWithTime $ dynamicTracer - , dtConnectionManagerTransitionTracer = nullTracer + , dtConnectionManagerTransitionTracer = contramap + DiffusionConnectionManagerTransitionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ dynamicTracer , dtServerTracer = nullTracer , dtInboundGovernorTracer = nullTracer , dtInboundGovernorTransitionTracer = nullTracer @@ -671,6 +688,113 @@ prop_diffusion_target_active_local_above defaultBearerInfo diffScript = <*> demotionOpportunities <*> demotionOpportunitiesIgnoredTooLong) + +-- | A variant of ouroboros-network-framework +-- 'Test.Ouroboros.Network.Server2.prop_connection_manager_valid_transitions' +-- but for running on Diffusion. This means it has to have in consideration +-- that 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_cm_valid_transitions :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_diffusion_cm_valid_transitions 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_transitions + $ (\(WithName _ (WithTime _ b)) -> b) + <$> ev + ) + <$> events + + where + verify_cm_valid_transitions :: Trace () DiffusionTestTrace -> Property + verify_cm_valid_transitions events = + let abstractTransitionEvents :: Trace () (AbstractTransitionTrace NtNAddr) + abstractTransitionEvents = + selectDiffusionConnectionManagerTransitionEvents events + + connectionManagerEvents :: [ConnectionManagerTrace + NtNAddr + (ConnectionHandlerTrace + NtNVersion + NtNVersionData)] + connectionManagerEvents = + Trace.toList + . selectDiffusionConnectionManagerEvents + $ events + + in mkProperty + . bifoldMap + ( const mempty ) + ( \ trs + -> TestProperty { + tpProperty = + (counterexample $! + ( "\nconnection:\n" + ++ intercalate "\n" (map ppTransition trs)) + ) + . getAllProperty + . foldMap ( \ tr + -> AllProperty + . (counterexample $! + ( "\nUnexpected transition: " + ++ show tr) + ) + . verifyAbstractTransition + $ tr + ) + $ trs, + tpNumberOfTransitions = Sum (length trs), + tpNumberOfConnections = Sum 1, + tpNumberOfPrunings = classifyPrunings connectionManagerEvents, + tpNegotiatedDataFlows = [classifyNegotiatedDataFlow trs], + tpEffectiveDataFlows = [classifyEffectiveDataFlow trs], + tpTerminationTypes = [classifyTermination trs], + tpActivityTypes = [classifyActivityType trs], + tpTransitions = trs + } + ) + . fmap (map ttTransition) + . groupConns id abstractStateIsFinalTransition + $ abstractTransitionEvents + + -- Utils -- @@ -735,6 +859,29 @@ selectDiffusionPeerSelectionState f = DiffusionDebugPeerSelectionTrace (TraceGovernorState _ _ st) -> Just st _ -> Nothing) +selectDiffusionConnectionManagerEvents + :: Trace () DiffusionTestTrace + -> Trace () (ConnectionManagerTrace NtNAddr + (ConnectionHandlerTrace + NtNVersion + NtNVersionData)) +selectDiffusionConnectionManagerEvents = + Trace.fromList () + . mapMaybe + (\case DiffusionConnectionManagerTrace e -> Just e + _ -> Nothing) + . Trace.toList + +selectDiffusionConnectionManagerTransitionEvents + :: Trace () DiffusionTestTrace + -> Trace () (AbstractTransitionTrace NtNAddr) +selectDiffusionConnectionManagerTransitionEvents = + Trace.fromList () + . mapMaybe + (\case DiffusionConnectionManagerTransitionTrace e -> Just e + _ -> Nothing) + . Trace.toList + toBearerInfo :: AbsBearerInfo -> BearerInfo toBearerInfo abi = BearerInfo { 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 fff69916db1..0abd30b6834 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs @@ -25,7 +25,7 @@ import Control.Monad.Class.MonadThrow (MonadCatch, MonadEvaluate, MonadMask, MonadThrow, SomeException) import Control.Monad.Class.MonadTime (DiffTime, MonadTime) import Control.Monad.Class.MonadTimer (MonadTimer, threadDelay) -import Control.Tracer (nullTracer, Tracer, traceWith) +import Control.Tracer (Tracer, traceWith, nullTracer) import qualified Data.ByteString.Lazy as BL import Data.IP (IP (..), toIPv4, toIPv6) @@ -66,6 +66,7 @@ import qualified Ouroboros.Network.Diffusion.P2P as Diff.P2P import Ouroboros.Network.Testing.ConcreteBlock (Block) import Ouroboros.Network.Testing.Data.Script (Script (..)) +import Ouroboros.Network.Testing.Utils (genDelayWithPrecision) import Simulation.Network.Snocket (BearerInfo (..), withSnocket, FD) import qualified Test.Ouroboros.Network.Diffusion.Node as Node @@ -142,11 +143,11 @@ genDomainMap raps = do genCommands :: [(Int, Map RelayAccessPoint PeerAdvertise)] -> Gen [Command] genCommands localRoots = sized $ \size -> do - commands <- vectorOf size (frequency [ (7, JoinNetwork <$> shortDelay) + commands <- vectorOf size (frequency [ (7, JoinNetwork <$> delay) , (4, Reconfigure - <$> shortDelay + <$> delay <*> subLocalRootPeers) - , (1, Kill <$> longDelay) + , (1, Kill <$> delay) ]) return (fixupCommands commands) where @@ -155,8 +156,10 @@ genCommands localRoots = sized $ \size -> do subLRP <- sublistOf localRoots mapM (mapM (fmap Map.fromList . sublistOf . Map.toList)) subLRP - shortDelay = fromInteger <$> choose (0, 60) - longDelay = fromInteger <$> choose (1 * 60 * 60, 10 * 60 * 60) + delay = frequency [ (3, genDelayWithPrecision 100) + , (2, (* 10) <$> genDelayWithPrecision 100) + , (1, (/ 10) <$> genDelayWithPrecision 100) + ] fixupCommands :: [Command] -> [Command] fixupCommands [] = [] From 3861d5a13cd3285030d7c977e575902b80892666 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Wed, 20 Apr 2022 10:53:38 +0100 Subject: [PATCH 4/8] Fix comments --- ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index 0b5f77bc3df..990b8763b10 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs @@ -413,9 +413,6 @@ prop_diffusion_target_established_local defaultBearerInfo diffScript = -- 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_active_below :: AbsBearerInfo -> DiffusionScript -> Property @@ -568,9 +565,6 @@ prop_diffusion_target_active_below defaultBearerInfo diffScript = -- 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_active_local_above :: AbsBearerInfo -> DiffusionScript -> Property @@ -695,9 +689,6 @@ prop_diffusion_target_active_local_above defaultBearerInfo diffScript = -- that 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_cm_valid_transitions :: AbsBearerInfo -> DiffusionScript -> Property From 24064609661ff89d621707c4898f399c81632626 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Wed, 20 Apr 2022 10:53:51 +0100 Subject: [PATCH 5/8] Added cm_verify_transition_order --- .../test/Test/Ouroboros/Network/Testnet.hs | 68 ++++++++++++++++++- 1 file changed, 67 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index 990b8763b10..dccd2dfa81f 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs @@ -65,7 +65,7 @@ import TestLib.Utils (TestProperty(..), mkProperty, ppTransition, classifyEffectiveDataFlow, classifyTermination, classifyActivityType, classifyPrunings, groupConns) import TestLib.ConnectionManager - (verifyAbstractTransition, abstractStateIsFinalTransition) + (verifyAbstractTransition, abstractStateIsFinalTransition, verifyAbstractTransitionOrder) tests :: TestTree tests = @@ -85,6 +85,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 ] ] @@ -786,6 +788,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 False) + . fmap (map ttTransition) + . groupConns id abstractStateIsFinalTransition + $ abstractTransitionEvents + -- Utils -- From 662c9e62176e359cc7be6a3d7e86dd043cc28c2b Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Tue, 22 Feb 2022 11:50:46 +0000 Subject: [PATCH 6/8] Added IG Valid Transitions test --- .../test/Test/Ouroboros/Network/Testnet.hs | 95 ++++++++++++++++++- 1 file changed, 93 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index dccd2dfa81f..49d402dc365 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs @@ -36,7 +36,7 @@ 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(..)) +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 @@ -66,6 +66,7 @@ import TestLib.Utils (TestProperty(..), mkProperty, ppTransition, classifyActivityType, classifyPrunings, groupConns) import TestLib.ConnectionManager (verifyAbstractTransition, abstractStateIsFinalTransition, verifyAbstractTransitionOrder) +import TestLib.InboundGovernor (verifyRemoteTransition) tests :: TestTree tests = @@ -87,6 +88,8 @@ tests = prop_diffusion_cm_valid_transitions , testProperty "diffusion connection manager valid transition order" prop_diffusion_cm_valid_transition_order + , testProperty "diffusion inbound governor valid transitions" + prop_diffusion_ig_valid_transitions ] ] @@ -109,6 +112,8 @@ data DiffusionTestTrace = | DiffusionDiffusionSimulationTrace DiffusionSimulationTrace | DiffusionConnectionManagerTransitionTrace (AbstractTransitionTrace NtNAddr) + | DiffusionInboundGovernorTransitionTrace + (RemoteTransitionTrace NtNAddr) deriving (Show) tracersExtraWithTimeName @@ -162,7 +167,11 @@ tracersExtraWithTimeName ntnAddr = $ dynamicTracer , dtServerTracer = nullTracer , dtInboundGovernorTracer = nullTracer - , dtInboundGovernorTransitionTracer = nullTracer + , dtInboundGovernorTransitionTracer = contramap + DiffusionInboundGovernorTransitionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ dynamicTracer , dtLocalConnectionManagerTracer = nullTracer , dtLocalServerTracer = nullTracer , dtLocalInboundGovernorTracer = nullTracer @@ -852,6 +861,78 @@ prop_diffusion_cm_valid_transition_order defaultBearerInfo diffScript = . groupConns id abstractStateIsFinalTransition $ abstractTransitionEvents +-- | A variant of ouroboros-network-framework +-- 'Test.Ouroboros.Network.Server2.prop_inbound_governor_valid_transitions' +-- 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_transitions :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_diffusion_ig_valid_transitions 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_ig_valid_transitions + $ (\(WithName _ (WithTime _ b)) -> b) + <$> ev + ) + <$> events + + where + verify_ig_valid_transitions :: Trace () DiffusionTestTrace -> Property + verify_ig_valid_transitions events = + let remoteTransitionTraceEvents :: Trace () (RemoteTransitionTrace NtNAddr) + remoteTransitionTraceEvents = + selectDiffusionInboundGovernorTransitionEvents events + + in getAllProperty + . bifoldMap + ( \ _ -> AllProperty (property True) ) + ( \ TransitionTrace {ttPeerAddr = peerAddr, ttTransition = tr} -> + AllProperty + . counterexample (concat [ "Unexpected transition: " + , show peerAddr + , " " + , show tr + ]) + . verifyRemoteTransition + $ tr + ) + $ remoteTransitionTraceEvents + -- Utils -- @@ -939,6 +1020,16 @@ selectDiffusionConnectionManagerTransitionEvents = _ -> Nothing) . Trace.toList +selectDiffusionInboundGovernorTransitionEvents + :: Trace () DiffusionTestTrace + -> Trace () (RemoteTransitionTrace NtNAddr) +selectDiffusionInboundGovernorTransitionEvents = + Trace.fromList () + . mapMaybe + (\case DiffusionInboundGovernorTransitionTrace e -> Just e + _ -> Nothing) + . Trace.toList + toBearerInfo :: AbsBearerInfo -> BearerInfo toBearerInfo abi = BearerInfo { From 45371bd2fb2a914825a9a39acee41fc9d44810dc Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Tue, 22 Feb 2022 12:45:19 +0000 Subject: [PATCH 7/8] Added IG Valid Transition order test --- .../test/Test/Ouroboros/Network/Server2.hs | 2 +- .../testlib/TestLib/InboundGovernor.hs | 11 ++- .../test/Test/Ouroboros/Network/Testnet.hs | 75 ++++++++++++++++++- 3 files changed, 81 insertions(+), 7 deletions(-) diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index e58863fc97e..d58f3144513 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -2698,7 +2698,7 @@ prop_inbound_governor_valid_transition_order serverAcc (ArbDataFlow dataFlow) MainReturn {} -> mempty _ -> AllProperty (property False) ) - verifyRemoteTransitionOrder + (verifyRemoteTransitionOrder True) . fmap (map ttTransition) . groupConns id remoteStrIsFinalTransition $ remoteTransitionTraceEvents diff --git a/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs b/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs index 5c7d76ef654..c7fafd402f5 100644 --- a/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs +++ b/ouroboros-network-framework/testlib/TestLib/InboundGovernor.hs @@ -133,10 +133,13 @@ allValidRemoteTransitionsNames = -- 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. -verifyRemoteTransitionOrder :: [RemoteTransition] +verifyRemoteTransitionOrder :: Bool -- ^ Check last transition: useful for + -- distinguish Diffusion layer tests + -- vs non-Diffusion ones. + -> [RemoteTransition] -> AllProperty -verifyRemoteTransitionOrder [] = mempty -verifyRemoteTransitionOrder (h:t) = go t h +verifyRemoteTransitionOrder _ [] = mempty +verifyRemoteTransitionOrder checkLast (h:t) = go t h where go :: [RemoteTransition] -> RemoteTransition -> AllProperty -- All transitions must end in the 'Nothing' (final) state, and since @@ -147,7 +150,7 @@ verifyRemoteTransitionOrder (h:t) = go t h AllProperty $ counterexample ("\nUnexpected last transition: " ++ show tr) - (property False) + (property (not checkLast)) -- 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. diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index 49d402dc365..7710c3857d3 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 @@ -66,7 +67,9 @@ import TestLib.Utils (TestProperty(..), mkProperty, ppTransition, classifyActivityType, classifyPrunings, groupConns) import TestLib.ConnectionManager (verifyAbstractTransition, abstractStateIsFinalTransition, verifyAbstractTransitionOrder) -import TestLib.InboundGovernor (verifyRemoteTransition) +import TestLib.InboundGovernor + (verifyRemoteTransition, verifyRemoteTransitionOrder, + remoteStrIsFinalTransition) tests :: TestTree tests = @@ -90,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 ] ] @@ -933,6 +938,72 @@ 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 () (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_ig_valid_transition_order + $ (\(WithName _ (WithTime _ b)) -> b) + <$> ev + ) + <$> events + + where + verify_ig_valid_transition_order :: Trace () DiffusionTestTrace -> Property + verify_ig_valid_transition_order events = + + let remoteTransitionTraceEvents :: Trace () (RemoteTransitionTrace NtNAddr) + remoteTransitionTraceEvents = + selectDiffusionInboundGovernorTransitionEvents events + + in getAllProperty + . bifoldMap + (const mempty) + (verifyRemoteTransitionOrder False) + . fmap (map ttTransition) + . groupConns id remoteStrIsFinalTransition + $ remoteTransitionTraceEvents + -- Utils -- From ee0f8d5d3fcd016d9a4a95f4bb635d73c0b7c433 Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Tue, 26 Apr 2022 17:17:21 +0100 Subject: [PATCH 8/8] Reduce time on diffusion tests --- .../test/Test/Ouroboros/Network/Testnet.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index 7710c3857d3..df348d6fa8d 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs @@ -208,7 +208,7 @@ prop_diffusion_nolivelock defaultBearerInfo diffScript@(DiffusionScript l) = tracerDiffusionSimWithTimeName trace :: [(Time, ThreadId, Maybe ThreadLabel, SimEventType)] - trace = take 1000000 + trace = take 500000 . traceEvents $ runSimTrace sim @@ -295,7 +295,7 @@ prop_diffusion_target_established_local defaultBearerInfo diffScript = @NtNAddr . Trace.fromList (MainReturn (Time 0) () []) . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) - . take 1000000 + . take 500000 . traceEvents $ runSimTrace sim @@ -456,7 +456,7 @@ prop_diffusion_target_active_below defaultBearerInfo diffScript = @NtNAddr . Trace.fromList (MainReturn (Time 0) () []) . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) - . take 1000000 + . take 500000 . traceEvents $ runSimTrace sim @@ -608,7 +608,7 @@ prop_diffusion_target_active_local_above defaultBearerInfo diffScript = @NtNAddr . Trace.fromList (MainReturn (Time 0) () []) . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) - . take 1000000 + . take 500000 . traceEvents $ runSimTrace sim @@ -731,7 +731,7 @@ prop_diffusion_cm_valid_transitions defaultBearerInfo diffScript = @NtNAddr . Trace.fromList (MainReturn (Time 0) () []) . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) - . take 1000000 + . take 500000 . traceEvents $ runSimTrace sim @@ -834,7 +834,7 @@ prop_diffusion_cm_valid_transition_order defaultBearerInfo diffScript = @NtNAddr . Trace.fromList (MainReturn (Time 0) () []) . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) - . take 1000000 + . take 500000 . traceEvents $ runSimTrace sim @@ -898,7 +898,7 @@ prop_diffusion_ig_valid_transitions defaultBearerInfo diffScript = @NtNAddr . Trace.fromList (MainReturn (Time 0) () []) . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) - . take 1000000 + . take 500000 . traceEvents $ runSimTrace sim @@ -970,7 +970,7 @@ prop_diffusion_ig_valid_transition_order defaultBearerInfo diffScript = @NtNAddr . Trace.fromList (MainReturn (Time 0) () []) . fmap (\(t, tid, tl, te) -> SimEvent t tid tl te) - . take 1000000 + . take 500000 . traceEvents $ runSimTrace sim