Only trace the MsgRequestTxs and MsgReplyTxs cases

IntersectMBO · Feb 18, 2020 · 0aef763 · 0aef763
1 parent 1339868
commit 0aef763
Showing 1 changed file with 22 additions and 1 deletion.
diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans  #-}
@@ -32,6 +33,7 @@ import           Data.Functor.Contravariant (contramap)
 import           Data.Text (Text, pack)
 import           Network.Mux (MuxTrace, WithMuxBearer)
 import qualified Network.Socket as Socket (SockAddr)
+import           Network.TypedProtocol.Codec (AnyMessage (..))
 
 import           Cardano.BM.Data.Aggregated (Measurable (..))
 import           Cardano.BM.Data.LogItem (LOContent (..), LogObject (..),
@@ -60,8 +62,11 @@ import           Ouroboros.Network.Block (Point, BlockNo(..),
                                           blockNo, unBlockNo, unSlotNo)
 import           Ouroboros.Network.BlockFetch.Decision (FetchDecision)
 import           Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
-import           Ouroboros.Network.NodeToNode (WithAddr, ErrorPolicyTrace)
+import           Ouroboros.Network.NodeToNode (WithAddr, ErrorPolicyTrace,
+                                               TraceSendRecv (..))
 import           Ouroboros.Network.Point (fromWithOrigin)
+import           Ouroboros.Network.Protocol.TxSubmission.Type (Message (..),
+                                                               TxSubmission)
 import           Ouroboros.Network.Subscription
 
 import qualified Ouroboros.Storage.ChainDB as ChainDB
@@ -462,6 +467,7 @@ mkTracers traceOptions tracer = do
         $ showTracing $ withName "BlockFetchProtocol" tracer
       , ptTxSubmissionTracer
         = tracerOnOff (traceTxSubmissionProtocol traceOpts)
+        $ traceMsgRequestAndReplyTxs
         $ toLogObject' StructuredLogging tracingVerbosity
         $ addName "TxSubmissionProtocol" tracer
       , ptLocalChainSyncTracer
@@ -475,6 +481,21 @@ mkTracers traceOptions tracer = do
         $ showTracing $ withName "LocalStateQueryProtocol" tracer
       }
 
+    -- Only trace the 'MsgRequestTxs' and 'MsgReplyTxs' cases.
+    traceMsgRequestAndReplyTxs
+      :: Tracer IO (TraceLabelPeer peer (TraceSendRecv (TxSubmission txid tx)))
+      -> Tracer IO (TraceLabelPeer peer (TraceSendRecv (TxSubmission txid tx)))
+    traceMsgRequestAndReplyTxs tr =
+        Tracer $ \ev@(TraceLabelPeer _peerid traceSendRecv) ->
+          case getMsg traceSendRecv of
+            AnyMessage (MsgRequestTxs _txids) -> traceWith tr ev
+            AnyMessage (MsgReplyTxs _txs)     -> traceWith tr ev
+            _                                 -> pure ()
+      where
+        getMsg :: forall ps. TraceSendRecv ps -> AnyMessage ps
+        getMsg (TraceSendMsg msg) = msg
+        getMsg (TraceRecvMsg msg) = msg
+
 -- | get information about a chain fragment
 
 data ChainInformation = ChainInformation