Even more Consensus tracers

cardano-node/src/Cardano/TraceDispatcher/ConsensusTracer/Combinators.hs

@@ -25,6 +25,13 @@ module Cardano.TraceDispatcher.ConsensusTracer.Combinators
   , severityTxOutbound
   , namesForTxOutbound
 
+  , severityLocalTxSubmissionServer
+  , namesForLocalTxSubmissionServer
+
+  , severityMempool
+  , namesForMempool
+
+
   ) where
 
 
@@ -37,12 +44,15 @@ import           Ouroboros.Network.BlockFetch.Decision
 import           Ouroboros.Network.TxSubmission.Inbound
 import           Ouroboros.Network.TxSubmission.Outbound
 
-import           Ouroboros.Consensus.Block ({-ForgeStateInfo,-} Point)
+import           Ouroboros.Consensus.Block (Point)
 import           Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, GenTxId)
+import           Ouroboros.Consensus.Mempool.API (TraceEventMempool (..))
 import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
                      (TraceBlockFetchServerEvent (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
+import           Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
+                     (TraceLocalTxSubmissionServerEvent (..))
 -- import qualified Ouroboros.Consensus.Node.Tracers as Consensus
 
 
@@ -221,3 +231,24 @@ namesForTxOutbound' TraceTxSubmissionOutboundSendMsgReplyTxs {} =
     ["TxSubmissionOutboundSendMsgReply"]
 namesForTxOutbound' TraceControlMessage {} =
     ["ControlMessage"]
+
+severityLocalTxSubmissionServer ::
+     (TraceLocalTxSubmissionServerEvent blk)
+  -> SeverityS
+severityLocalTxSubmissionServer _ = Info
+
+namesForLocalTxSubmissionServer ::
+  (TraceLocalTxSubmissionServerEvent blk)
+  -> [Text]
+namesForLocalTxSubmissionServer TraceReceivedTx {} = ["ReceivedTx"]
+
+severityMempool ::
+     (TraceEventMempool blk)
+  -> SeverityS
+severityMempool _ = Info
+
+namesForMempool :: TraceEventMempool blk -> [Text]
+namesForMempool TraceMempoolAddedTx {}            = ["AddedTx"]
+namesForMempool TraceMempoolRejectedTx {}         = ["RejectedTx"]
+namesForMempool TraceMempoolRemoveTxs {}          = ["RemoveTxs"]
+namesForMempool TraceMempoolManuallyRemovedTxs {} = ["ManuallyRemovedTxs"]

cardano-node/src/Cardano/TraceDispatcher/ConsensusTracer/Docu.hs

@@ -12,6 +12,8 @@ module Cardano.TraceDispatcher.ConsensusTracer.Docu
   , docBlockFetchServer
   , docTxInbound
   , docTxOutbound
+  , docLocalTxSubmissionServer
+  , docMempool
   ) where
 
 import           Cardano.Logging
@@ -20,10 +22,16 @@ import           Data.Time.Clock
 
 
 import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx,
+                     GenTxId)
+import           Ouroboros.Consensus.Mempool.API (MempoolSize (..),
+                     TraceEventMempool (..))
 import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
                      (TraceBlockFetchServerEvent (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
+import           Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
+                     (TraceLocalTxSubmissionServerEvent (..))
 
 import           Ouroboros.Network.Block
 import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
@@ -102,6 +110,19 @@ protoTxId = undefined
 protoControlMessage :: ControlMessage
 protoControlMessage = undefined
 
+protoGenTx :: GenTx blk
+protoGenTx = undefined
+
+protoGenTxId :: GenTxId blk
+protoGenTxId = undefined
+
+protoMempoolSize :: MempoolSize
+protoMempoolSize = undefined
+
+-- Not working because of type families
+-- protoApplyTxErr :: ApplyTxErr blk
+-- protoApplyTxErr = undefined
+
 --------------------
 
 docChainSyncClientEvent :: Documented (TraceChainSyncClientEvent blk)
@@ -308,12 +329,33 @@ docTxOutbound = Documented [
     "TODO"
   ]
 
--- data TraceTxSubmissionOutbound txid tx
--- = TraceTxSubmissionOutboundRecvMsgRequestTxs
---     [txid]
---     -- ^ The IDs of the transactions requested.
--- | TraceTxSubmissionOutboundSendMsgReplyTxs
---     [tx]
---     -- ^ The transactions to be sent in the response.
--- | TraceControlMessage ControlMessage
--- deriving Show
+docLocalTxSubmissionServer :: Documented (TraceLocalTxSubmissionServerEvent blk)
+docLocalTxSubmissionServer = Documented [
+    DocMsg
+    (TraceReceivedTx protoGenTx)
+    []
+    "A transaction was received."
+  ]
+
+docMempool :: forall blk. Documented (TraceEventMempool blk)
+docMempool = Documented [
+    DocMsg
+      (TraceMempoolAddedTx protoGenTx protoMempoolSize protoMempoolSize)
+      []
+      "New, valid transaction that was added to the Mempool."
+  , DocMsg
+      (TraceMempoolRejectedTx protoGenTx (undefined :: ApplyTxErr blk) protoMempoolSize)
+      []
+      "New, invalid transaction thas was rejected and thus not added to\
+      \ the Mempool."
+  , DocMsg
+      (TraceMempoolRemoveTxs [protoGenTx] protoMempoolSize)
+      []
+      "Previously valid transactions that are no longer valid because of\
+      \ changes in the ledger state. These transactions have been removed\
+      \ from the Mempool."
+  , DocMsg
+      (TraceMempoolManuallyRemovedTxs [protoGenTxId] [protoGenTx] protoMempoolSize)
+      []
+      "Transactions that have been manually removed from the Mempool."
+  ]

cardano-node/src/Cardano/TraceDispatcher/ConsensusTracer/Formatting.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE TypeFamilies         #-}
@@ -11,7 +12,7 @@ module Cardano.TraceDispatcher.ConsensusTracer.Formatting
   (
   ) where
 
-import           Data.Aeson (Value (String), toJSON, (.=))
+import           Data.Aeson (ToJSON, Value (String), toJSON, (.=))
 import qualified Data.Text as Text
 import           Text.Show
 
@@ -25,11 +26,17 @@ import           Cardano.TraceDispatcher.OrphanInstances.Shelley ()
 import           Cardano.TraceDispatcher.Render
 
 import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx,
+                     GenTxId)
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
+import           Ouroboros.Consensus.Mempool.API (MempoolSize (..),
+                     TraceEventMempool (..))
 import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
                      (TraceBlockFetchServerEvent (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
+import           Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
+                     (TraceLocalTxSubmissionServerEvent (..))
 
 import           Ouroboros.Network.Block
 import           Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
@@ -39,6 +46,7 @@ import           Ouroboros.Network.TxSubmission.Inbound
 import           Ouroboros.Network.TxSubmission.Outbound
 
 
+
 instance (Show (Header blk), ConvertRawHash blk, LedgerSupportsProtocol blk)
       => LogFormatting (TraceChainSyncClientEvent blk) where
   forHuman (TraceDownloadedHeader pt) =
@@ -204,3 +212,44 @@ instance (Show txid, Show tx)
     mkObject
       [ "kind" .= String "TraceControlMessage"
       ]
+
+instance LogFormatting (TraceLocalTxSubmissionServerEvent blk) where
+  forMachine _dtal (TraceReceivedTx _gtx) =
+    mkObject [ "kind" .= String "ReceivedTx" ]
+
+instance ( Show (ApplyTxErr blk), LogFormatting (ApplyTxErr blk), LogFormatting (GenTx blk),
+           ToJSON (GenTxId blk)
+         ) => LogFormatting (TraceEventMempool blk) where
+  forMachine dtal (TraceMempoolAddedTx tx _mpSzBefore mpSzAfter) =
+    mkObject
+      [ "kind" .= String "TraceMempoolAddedTx"
+      , "tx" .= forMachine dtal tx
+      , "mempoolSize" .= forMachine dtal mpSzAfter
+      ]
+  forMachine dtal (TraceMempoolRejectedTx tx txApplyErr mpSz) =
+    mkObject
+      [ "kind" .= String "TraceMempoolRejectedTx"
+      , "err" .= forMachine dtal txApplyErr
+      , "tx" .= forMachine dtal tx
+      , "mempoolSize" .= forMachine dtal mpSz
+      ]
+  forMachine dtal (TraceMempoolRemoveTxs txs mpSz) =
+    mkObject
+      [ "kind" .= String "TraceMempoolRemoveTxs"
+      , "txs" .= map (forMachine dtal) txs
+      , "mempoolSize" .= forMachine dtal mpSz
+      ]
+  forMachine dtal (TraceMempoolManuallyRemovedTxs txs0 txs1 mpSz) =
+    mkObject
+      [ "kind" .= String "TraceMempoolManuallyRemovedTxs"
+      , "txsRemoved" .= txs0
+      , "txsInvalidated" .= map (forMachine dtal) txs1
+      , "mempoolSize" .= forMachine dtal mpSz
+      ]
+
+instance LogFormatting MempoolSize where
+  forMachine _dtal MempoolSize{msNumTxs, msNumBytes} =
+    mkObject
+      [ "numTxs" .= msNumTxs
+      , "bytes" .= msNumBytes
+      ]

cardano-node/src/Cardano/TraceDispatcher/Tracers.hs

@@ -15,7 +15,7 @@ module Cardano.TraceDispatcher.Tracers
 
 import           Cardano.Prelude hiding (trace)
 import qualified Data.Text.IO as T
-
+import           Data.Aeson (ToJSON)
 import           Cardano.Logging
 import           Cardano.TraceDispatcher.ChainDBTracer.Combinators
 import           Cardano.TraceDispatcher.ChainDBTracer.Docu
@@ -42,15 +42,19 @@ import           Ouroboros.Consensus.Byron.Ledger (ByronBlock)
 import           Ouroboros.Consensus.Byron.Ledger.Config (BlockConfig)
 import           Ouroboros.Consensus.Ledger.Inspect (InspectLedger,
                      LedgerUpdate, LedgerWarning)
-import           Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, GenTxId, TxId)
+import           Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, GenTxId,
+                     TxId, ApplyTxErr)
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
                      (LedgerSupportsProtocol)
+import           Ouroboros.Consensus.Mempool.API (TraceEventMempool (..))
 import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
                      (TraceBlockFetchServerEvent (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (TraceChainSyncClientEvent)
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
                      (TraceChainSyncServerEvent)
+import           Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
+                     (TraceLocalTxSubmissionServerEvent (..))
 import qualified Ouroboros.Consensus.Network.NodeToClient as NodeToClient
 import qualified Ouroboros.Consensus.Network.NodeToNode as NodeToNode
 import qualified Ouroboros.Consensus.Node.Run as Consensus (RunNode)
@@ -184,10 +188,36 @@ txOutboundTracer trBase = do
     pure $ withNamesAppended namesForTxOutbound
             $ withSeverity severityTxOutbound cdbmTrNs
 
+localTxSubmissionServerTracer ::
+     Trace IO FormattedMessage
+  -> IO (Trace IO (TraceLocalTxSubmissionServerEvent blk))
+localTxSubmissionServerTracer trBase = do
+    tr <- humanFormatter True "Cardano" trBase
+    let cdbmTrNs = appendName "LocalTxSubmissionServerEvent" $ appendName "Node" tr
+    pure $ withNamesAppended namesForLocalTxSubmissionServer
+            $ withSeverity severityLocalTxSubmissionServer cdbmTrNs
+
+mempoolTracer ::
+  ( Show (ApplyTxErr blk)
+  , LogFormatting (ApplyTxErr blk)
+  , LogFormatting (GenTx blk)
+  , ToJSON (GenTxId blk))
+  => Trace IO FormattedMessage
+  -> IO (Trace IO (TraceEventMempool blk))
+mempoolTracer trBase = do
+    tr <- humanFormatter True "Cardano" trBase
+    let cdbmTrNs = appendName "Mempool" $ appendName "Node" tr
+    pure $ withNamesAppended namesForMempool
+            $ withSeverity severityMempool cdbmTrNs
+
 docTracers :: forall blk remotePeer.
   ( Show remotePeer
   , Show (TxId (GenTx blk))
   , Show (GenTx blk)
+  , Show (ApplyTxErr blk)
+  , LogFormatting (ApplyTxErr blk)
+  , LogFormatting (GenTx blk)
+  , ToJSON (GenTxId blk)
   )
   => IO ()
 docTracers = do
@@ -201,6 +231,8 @@ docTracers = do
   bfsTr  <- blockFetchServerTracer trBase
   txiTr  <- txInboundTracer trBase
   txoTr  <- txOutboundTracer trBase
+  ltxsTr <- localTxSubmissionServerTracer trBase
+  mpTr   <- mempoolTracer trBase
 
   cdbmTrDoc    <- documentMarkdown
               (docChainDBTraceEvent :: Documented
@@ -236,6 +268,15 @@ docTracers = do
                 (BlockFetch.TraceLabelPeer remotePeer
                   (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))))
               [txoTr]
+  ltxsTrDoc    <- documentMarkdown
+              (docLocalTxSubmissionServer :: Documented
+                (TraceLocalTxSubmissionServerEvent blk))
+              [ltxsTr]
+  mpTrDoc    <- documentMarkdown
+              (docMempool :: Documented
+                (TraceEventMempool blk))
+              [mpTr]
+
   let bl = cdbmTrDoc
         ++ cscTrDoc
         ++ csshTrDoc
@@ -244,6 +285,9 @@ docTracers = do
         ++ bfsTrDoc
         ++ txiTrDoc
         ++ txoTrDoc
+        ++ ltxsTrDoc
+        ++ mpTrDoc
+
   T.writeFile "/home/yupanqui/IOHK/CardanoLogging.md" (buildersToText bl)
 
 -- | Tracers for all system components.
@@ -276,7 +320,8 @@ mkDispatchTracers _blockConfig (TraceDispatcher _trSel) _tr _nodeKern _ekgDirect
   txiTr  <- txInboundTracer trBase
   bfsTr :: (Trace IO (TraceBlockFetchServerEvent blk)) <- blockFetchServerTracer trBase
   txoTr  <- txOutboundTracer trBase
-
+  ltxsTr <- localTxSubmissionServerTracer trBase
+  mpTr   <- mempoolTracer trBase
 
   configureTracers emptyTraceConfig docChainDBTraceEvent [cdbmTr]
   configureTracers emptyTraceConfig docChainSyncClientEvent [cscTr]
@@ -286,7 +331,8 @@ mkDispatchTracers _blockConfig (TraceDispatcher _trSel) _tr _nodeKern _ekgDirect
   configureTracers emptyTraceConfig docBlockFetchClient     [bfcTr]
   configureTracers emptyTraceConfig docBlockFetchServer     [bfsTr]
   configureTracers emptyTraceConfig docTxInbound            [txiTr]
-
+  configureTracers emptyTraceConfig docLocalTxSubmissionServer [ltxsTr]
+  configureTracers emptyTraceConfig docMempool              [mpTr]
 
   pure Tracers
     { chainDBTracer = Tracer (traceWith cdbmTr)
@@ -300,8 +346,8 @@ mkDispatchTracers _blockConfig (TraceDispatcher _trSel) _tr _nodeKern _ekgDirect
       , Consensus.forgeStateInfoTracer = nullTracer
       , Consensus.txInboundTracer = Tracer (traceWith txiTr)
       , Consensus.txOutboundTracer = Tracer (traceWith txoTr)
-      , Consensus.localTxSubmissionServerTracer = nullTracer
-      , Consensus.mempoolTracer = nullTracer
+      , Consensus.localTxSubmissionServerTracer = Tracer (traceWith ltxsTr)
+      , Consensus.mempoolTracer = Tracer (traceWith mpTr)
       , Consensus.forgeTracer = nullTracer
       , Consensus.blockchainTimeTracer = nullTracer
       , Consensus.keepAliveClientTracer = nullTracer