Add testnet tx submission test

Author: bolt12

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs

@@ -41,7 +41,7 @@ import Control.Monad.Class.MonadThrow (MonadEvaluate, MonadMask, MonadThrow,
 import Control.Monad.Class.MonadTime.SI (DiffTime, MonadTime)
 import Control.Monad.Class.MonadTimer.SI (MonadDelay, MonadTimer)
 import Control.Monad.Fix (MonadFix)
-import Control.Tracer (Tracer (..), nullTracer)
+import Control.Tracer (Tracer (..), contramap, nullTracer)
 
 import Data.Foldable as Foldable (foldl')
 import Data.IP (IP (..))
@@ -283,7 +283,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch =
                withAsync (blockFetch nodeKernel) $ \blockFetchLogicThread ->
 
                  withAsync (decisionLogicThread
-                              nullTracer
+                              (contramap show $ aDebugTracer na)
                               (aTxDecisionPolicy na)
                               (readPeerGSVs (nkFetchClientRegistry nodeKernel))
                               (nkTxChannelsVar nodeKernel)

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs

@@ -694,21 +694,6 @@ applications debugTracer nodeKernel
               channel
               (txSubmissionServerPeerPipelined server)
 
-    -- aTxSubmission2Server
-    --   :: NodeToNodeVersion
-    --   -> ResponderContext addrNTN
-    --   -> Channel m bTX
-    --   -> m ((), Maybe bTX)
-    -- aTxSubmission2Server version ResponderContext { rcConnectionId = them } channel = do
-    --   labelThisThread "TxSubmissionServer"
-    --   runPipelinedPeerWithLimits
-    --     (contramap (TraceLabelPeer them) tTxSubmission2Tracer)
-    --     (cTxSubmission2Codec (mkCodecs version))
-    --     blTxSubmission2
-    --     timeLimitsTxSubmission2
-    --     channel
-    --     (txSubmissionServerPeerPipelined (hTxSubmissionServer version them))
-
 --
 -- Orphaned Instances
 --

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs

@@ -70,7 +70,7 @@ import Test.QuickCheck.Monoids
 import Test.Tasty
 import Test.Tasty.QuickCheck (testProperty)
 
-import Control.Exception (AssertionFailed (..), catch, evaluate)
+import Control.Exception (AssertionFailed (..), catch, evaluate, fromException)
 import Ouroboros.Network.BlockFetch (FetchMode (..), TraceFetchClientState (..))
 import Ouroboros.Network.ConnectionManager.Test.Timeouts (TestProperty (..),
            classifyActivityType, classifyEffectiveDataFlow,
@@ -101,6 +101,7 @@ import Control.Monad.Class.MonadTest (exploreRaces)
 import Ouroboros.Network.PeerSelection.Bootstrap (requiresBootstrapPeers)
 import Ouroboros.Network.PeerSelection.LedgerPeers
 import Ouroboros.Network.TxSubmission.Inbound.Policy (defaultTxDecisionPolicy)
+import Ouroboros.Network.TxSubmission.Outbound (TxSubmissionProtocolError (..))
 
 tests :: TestTree
 tests =
@@ -156,6 +157,10 @@ tests =
                       (testWithIOSimPOR prop_only_bootstrap_peers_in_fallback_state 10000)
     , nightlyTest $ testProperty "no non trustable peers before caught up state"
                       (testWithIOSimPOR prop_no_non_trustable_peers_before_caught_up_state 10000)
+    , testGroup "Tx Submission"
+      [ nightlyTest $ testProperty "no protocol errors"
+                        (testWithIOSimPOR prop_no_txSubmission_error 125000)
+      ]
     , testGroup "Churn"
       [ nightlyTest $ testProperty "no timeouts"
                         (testWithIOSimPOR prop_churn_notimeouts 10000)
@@ -221,6 +226,10 @@ tests =
       [ testProperty "share a peer"
                      unit_peer_sharing
       ]
+    , testGroup "Tx Submission"
+      [ testProperty "no protocol errors"
+                     (testWithIOSim prop_no_txSubmission_error 125000)
+      ]
     , testGroup "Churn"
       [ testProperty "no timeouts"
                      (testWithIOSim prop_churn_notimeouts 125000)
@@ -418,6 +427,35 @@ prop_inbound_governor_trace_coverage defaultBearerInfo diffScript =
    in tabulate "inbound governor trace" eventsSeenNames
       True
 
+-- | This test check that we don't have any tx submission protocol error
+--
+prop_no_txSubmission_error :: SimTrace Void
+                           -> Int
+                           -> Property
+prop_no_txSubmission_error ioSimTrace traceNumber =
+  let events = Trace.toList
+             . fmap (\(WithTime t (WithName _ b)) -> (t, b))
+             . withTimeNameTraceEvents
+                @DiffusionTestTrace
+                @NtNAddr
+             . Trace.take traceNumber
+             $ ioSimTrace
+
+   in counterexample (intercalate "\n" $ map show $ events)
+    $ all (\case
+             (_, DiffusionInboundGovernorTrace (TrMuxErrored _ err)) ->
+               case fromException err of
+                 Just ProtocolErrorRequestBlocking               -> False
+                 Just ProtocolErrorRequestedNothing              -> False
+                 Just ProtocolErrorAckedTooManyTxids             -> False
+                 Just (ProtocolErrorRequestedTooManyTxids _ _ _) -> False
+                 Just ProtocolErrorRequestNonBlocking            -> False
+                 Just ProtocolErrorRequestedUnavailableTx        -> False
+                 _                                               -> True
+             _                                                   -> True
+          )
+          events
+
 -- | This test coverage of InboundGovernor transitions.
 --
 prop_inbound_governor_transitions_coverage :: AbsBearerInfo

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Simulation/Node.hs

@@ -161,10 +161,11 @@ data SimArgs =
     }
 
 instance Show SimArgs where
-    show SimArgs { saSlot, saQuota } =
+    show SimArgs { saSlot, saQuota, saTxDecisionPolicy } =
       unwords [ "SimArgs"
               , show saSlot
               , show saQuota
+              , "(" ++ show saTxDecisionPolicy ++ ")"
               ]
 
 data ServiceDomainName =
@@ -228,7 +229,7 @@ instance Show NodeArgs where
     show NodeArgs { naSeed, naDiffusionMode, naMbTime, naBootstrapPeers, naPublicRoots,
                    naAddr, naPeerSharing, naLocalRootPeers, naLocalSelectionTargets,
                    naDNSTimeoutScript, naDNSLookupDelayScript, naChainSyncExitOnBlockNo,
-                   naChainSyncEarlyExit, naFetchModeScript } =
+                   naChainSyncEarlyExit, naFetchModeScript, naTxs } =
       unwords [ "NodeArgs"
               , "(" ++ show naSeed ++ ")"
               , show naDiffusionMode
@@ -244,6 +245,7 @@ instance Show NodeArgs where
               , "(" ++ show naChainSyncExitOnBlockNo ++ ")"
               , show naChainSyncEarlyExit
               , show naFetchModeScript
+              , show naTxs
               ]
 
 data Command = JoinNetwork DiffTime