tx-submission: added DebugTxLogic tracer

Module structure needs to be reorganised to have just one debug tracer.

Author: coot

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

@@ -107,7 +107,8 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSLookupType)
 import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency,
            WarmValency)
 import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy)
-import Ouroboros.Network.TxSubmission.Inbound.Registry (decisionLogicThread)
+import Ouroboros.Network.TxSubmission.Inbound.Registry (DebugTxLogic,
+           decisionLogicThread)
 import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState)
 import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound)
 import Test.Ouroboros.Network.Diffusion.Node.ChainDB (addBlock,
@@ -205,8 +206,9 @@ run :: forall resolver m.
     -> Tracer m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader))
     -> Tracer m (TraceTxSubmissionInbound Int (Tx Int))
     -> Tracer m (DebugSharedTxState NtNAddr Int (Tx Int))
+    -> Tracer m (DebugTxLogic NtNAddr Int (Tx Int))
     -> m Void
-run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch tracerTxSubmissionInbound tracerTxSubmissionDebug =
+run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch tracerTxSubmissionInbound tracerTxSubmissionDebug tracerTxLogic =
     Node.withNodeKernelThread blockGeneratorArgs (aTxs na)
       $ \ nodeKernel nodeKernelThread -> do
         dnsTimeoutScriptVar <- newTVarIO (aDNSTimeoutScript na)
@@ -292,7 +294,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch tracerTxSubmis
                withAsync (blockFetch nodeKernel) $ \blockFetchLogicThread ->
 
                  withAsync (decisionLogicThread
-                              tracerTxSubmissionDebug
+                              tracerTxLogic
                               (aTxDecisionPolicy na)
                               (readPeerGSVs (nkFetchClientRegistry nodeKernel))
                               (nkTxChannelsVar nodeKernel)

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

@@ -144,6 +144,7 @@ import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing,
 import Ouroboros.Network.Protocol.TxSubmission2.Codec (byteLimitsTxSubmission2,
            timeLimitsTxSubmission2)
 import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy)
+import Ouroboros.Network.TxSubmission.Inbound.Registry (DebugTxLogic)
 import Ouroboros.Network.TxSubmission.Inbound.State (DebugSharedTxState)
 import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxSubmissionInbound)
 import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..), genLedgerPoolsFrom)
@@ -1004,6 +1005,7 @@ data DiffusionTestTrace =
     | DiffusionFetchTrace (TraceFetchClientState BlockHeader)
     | DiffusionTxSubmissionInbound (TraceTxSubmissionInbound Int (Tx Int))
     | DiffusionTxSubmissionDebug (DebugSharedTxState NtNAddr Int (Tx Int))
+    | DiffusionTxLogicDebug (DebugTxLogic NtNAddr Int (Tx Int))
     | DiffusionDebugTrace String
     deriving (Show)
 
@@ -1307,6 +1309,10 @@ diffusionSimulation
                      . tracerWithName addr
                      . tracerWithTime
                      $ nodeTracer)
+                     ( contramap DiffusionTxLogicDebug
+                     . tracerWithName addr
+                     . tracerWithTime
+                     $ nodeTracer)
 
     domainResolver :: StrictTVar m (Map Domain [(IP, TTL)])
                    -> DNSLookupType

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

@@ -138,14 +138,15 @@ runTxSubmissionV2
      )
   => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid)))
   -> Tracer m (DebugSharedTxState peeraddr txid (Tx txid))
+  -> Tracer m (DebugTxLogic peeraddr txid (Tx txid))
   -> Map peeraddr ( [Tx txid]
                   , ControlMessageSTM m
                   , Maybe DiffTime
                   , Maybe DiffTime
                   )
   -> TxDecisionPolicy
   -> m ([Tx txid], [[Tx txid]])
-runTxSubmissionV2 tracer tracerDST state txDecisionPolicy = do
+runTxSubmissionV2 tracer tracerDST tracerTxLogic state txDecisionPolicy = do
 
     state' <- traverse (\(b, c, d, e) -> do
         mempool <- newMempool b
@@ -190,10 +191,10 @@ runTxSubmissionV2 tracer tracerDST state txDecisionPolicy = do
                     -> m b
     runTxSubmission st txChannelsVar sharedTxStateVar
                     inboundMempool gsvVar k =
-      withAsync (decisionLogicThread tracerDST txDecisionPolicy (Strict.readTVar gsvVar) txChannelsVar sharedTxStateVar) $ \a -> do
+      withAsync (decisionLogicThread tracerTxLogic txDecisionPolicy (Strict.readTVar gsvVar) txChannelsVar sharedTxStateVar) $ \a -> do
             -- Construct txSubmission outbound client
         let clients = (\(addr, (mempool, ctrlMsgSTM, outDelay, _, outChannel, _)) -> do
-                        let client = txSubmissionOutbound verboseTracer
+                        let client = txSubmissionOutbound (Tracer $ say . show)
                                                (NumTxIdsToAck $ getNumTxIdsToReq
                                                               $ maxUnacknowledgedTxIds
                                                               $ txDecisionPolicy)
@@ -274,9 +275,9 @@ txSubmissionV2Simulation (TxSubmissionV2State state txDecisionPolicy) = do
         threadDelay (simDelayTime + 1000)
         atomically (traverse_ (`writeTVar` Terminate) controlMessageVars)
 
-  let tracer = verboseTracer <> debugTracer
-      tracer' = verboseTracer <> debugTracer
-  runTxSubmissionV2 tracer tracer' state'' txDecisionPolicy
+  let tracer :: forall a. Show a => Tracer (IOSim s) a
+      tracer = verboseTracer <> debugTracer
+  runTxSubmissionV2 tracer tracer tracer state'' txDecisionPolicy
 
 -- | Tests overall tx submission semantics. The properties checked in this
 -- property test are the same as for tx submission v1. We need this to know we

ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs

@@ -12,15 +12,17 @@ module Ouroboros.Network.TxSubmission.Inbound.Registry
   , newTxChannelsVar
   , PeerTxAPI (..)
   , decisionLogicThread
+  , DebugTxLogic (..)
   , withPeer
   ) where
 
 import Control.Concurrent.Class.MonadMVar.Strict
 import Control.Concurrent.Class.MonadSTM.Strict
+import Control.Monad.Class.MonadFork
 import Control.Monad.Class.MonadThrow
 import Control.Monad.Class.MonadTimer.SI
 
-import Data.Foldable (foldl', traverse_)
+import Data.Foldable (traverse_)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Maybe (fromMaybe)
@@ -211,22 +213,32 @@ withPeer tracer
       collectTxs tracer sharedStateVar peeraddr txids txs
 
 
+-- | TODO: reorganise modules so there's just one `Debug` tracer.
+data DebugTxLogic peeraddr txid tx =
+       DebugTxLogicSharedTxState (SharedTxState peeraddr txid tx)
+     | DebugTxLogicDecisions (Map peeraddr (TxDecision txid tx))
+  deriving Show
+
+
 decisionLogicThread
     :: forall m peeraddr txid tx.
        ( MonadDelay m
        , MonadMVar  m
        , MonadSTM   m
-       , MonadMask m
+       , MonadMask  m
+       , MonadFork  m
        , Ord peeraddr
        , Ord txid
        )
-    => Tracer m (DebugSharedTxState peeraddr txid tx)
+    => Tracer m (DebugTxLogic peeraddr txid tx)
     -> TxDecisionPolicy
     -> STM m (Map peeraddr PeerGSV)
     -> TxChannelsVar m peeraddr txid tx
     -> SharedTxStateVar m peeraddr txid tx
     -> m Void
-decisionLogicThread tracer policy readGSVVar txChannelsVar sharedStateVar = go
+decisionLogicThread tracer policy readGSVVar txChannelsVar sharedStateVar = do
+    labelThisThread "tx-decision"
+    go
   where
     go :: m Void
     go = do
@@ -247,7 +259,8 @@ decisionLogicThread tracer policy readGSVVar txChannelsVar sharedStateVar = go
         let (sharedState, decisions) = makeDecisions policy sharedCtx activePeers
         writeTVar sharedStateVar sharedState
         return (decisions, sharedState)
-      traceWith tracer (DebugSharedTxState "decisionLogicThread" st)
+      traceWith tracer (DebugTxLogicSharedTxState st)
+      traceWith tracer (DebugTxLogicDecisions decisions)
       TxChannels { txChannelMap } <- readMVar txChannelsVar
       traverse_
         (\(mvar, d) -> modifyMVarWithDefault_ mvar d (\d' -> pure (d' <> d)))