Fix tracing of tx submission for generator.

IntersectMBO · Aug 23, 2019 · 248f5c3 · 248f5c3
1 parent 2cd9655
commit 248f5c3
Show file tree

Hide file tree

Showing 2 changed files with 30 additions and 27 deletions.
diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs
@@ -130,18 +130,10 @@ runNode nodeCli@NodeCLIArguments{..} loggingLayer cc = do
         -- handleTxSubmission p topology tx tracer
 
       TxGenerator topology protocol -> do
-        let trace'      = appendName "generator" tr
-        let tracer      = contramap pack $ toLogObject trace'
-        -- These top-level tracers are used by tx submitter.
-        -- TODO: make it real, not an 'error' mock.
-        let tstx'       = appendName "bench-observables"     trace'
-            tct'        = appendName "conn-observables"      trace'
-            tsr'        = appendName "tx-submit-observables" trace'
-            tstx        = error "run, tstx TODO" -- contramap pack $ toLogObject tstx'
-            tct         = error "run, tct TODO"  -- contramap pack $ toLogObject tct'
-            tsr         = error "run, tsr TODO"  -- contramap pack $ toLogObject tsr'
-        SomeProtocol p  <- fromProtocol cc protocol
-        genesisBenchmarkRunner (tstx, tct, tsr) p topology
+        let trace'     = appendName "generator" tr
+        let tracerTx   = contramap pack $ toLogObject $ appendName "submit-tx" trace'
+        SomeProtocol p <- fromProtocol cc protocol
+        genesisBenchmarkRunner ((contramap show tracerTx), nullTracer, nullTracer) p topology
 
       TraceAcceptor -> do
         let trace'      = appendName "acceptor" tr

diff --git a/cardano-node/src/Cardano/Node/TxSubmission.hs b/cardano-node/src/Cardano/Node/TxSubmission.hs
@@ -29,6 +29,7 @@ module Cardano.Node.TxSubmission (
     ) where
 import           Cardano.Prelude hiding (ByteString, option, threadDelay)
 import           Prelude (String, error)
+import qualified Prelude as Prelude (Show (..))
 
 import           Data.ByteString.Lazy (ByteString)
 import           Data.Proxy
@@ -128,7 +129,7 @@ parseMockTxOut = (,)
           , help "Amount to transfer"
           ])
 
-{- 
+{-
 
 {-------------------------------------------------------------------------------
   Main logic
@@ -175,17 +176,27 @@ handleTxSubmission trs ptcl tinfo mocktx  = do
 --   outcome clear.
 data TraceSubmitTx blk where
   TraceSubmitTxStart
-    :: GenTxId blk -- ^ transaction id
+    :: Show (GenTxId blk)
+    => GenTxId blk -- ^ transaction id
     -> GenTx blk   -- ^ complete transaction
     -> TraceSubmitTx blk
   TraceSubmitTxSubmitted
-    :: GenTxId blk -- ^ transaction id
+    :: Show (GenTxId blk)
+    => GenTxId blk -- ^ transaction id
     -> TraceSubmitTx blk
   TraceSubmitTxRejected
-    :: GenTxId bl -- ^ transaction id
+    :: ( Show (GenTxId blk)
+       , Show (ApplyTxErr blk)
+       )
+    => GenTxId blk    -- ^ transaction id
     -> ApplyTxErr blk -- ^ error
     -> TraceSubmitTx blk
 
+instance Show (TraceSubmitTx blk) where
+    show (TraceSubmitTxStart txId _)    = "submitting tx " ++ (drop 5 (show txId))
+    show (TraceSubmitTxSubmitted txId)  = "tx " ++ (drop 5 (show txId)) ++ " submitted"
+    show (TraceSubmitTxRejected txId e) = "tx " ++ (drop 5 (show txId)) ++ " rejected with " ++ show e
+
 type TxSubmissionTracers m blk =
         ( Tracer m (TraceSubmitTx blk)
         -- ^ benchmarking observables
@@ -205,7 +216,7 @@ type TxSubmissionTracers m blk =
 launchBulkTxSubmitter
   :: ( MonadAsync m
      , MonadST m
-     , MonadSTM m     
+     , MonadSTM m
      , MonadThrow m
      , MonadTimer m
      , m ~ IO -- as connectTo only works in IO
@@ -280,23 +291,21 @@ bulkTxPeerEngine (tstx, _, tsr) pInfoConfig step =
 
 -- | Single shot transmitter - phase 1 PoC step
 submitTx :: ( RunDemo blk
+            , Show (GenTxId blk)
+            , Show (ApplyTxErr blk)
             )
          => TxSubmissionTracers IO blk
          -> NodeConfig (BlockProtocol blk)
          -> NodeId
          -> GenTx blk
          -> IO ()
-submitTx (_tstx, _tct, _tsr) pInfoConfig nodeId tx  = do
+submitTx (tstx, tct, tsr) pInfoConfig nodeId tx  = do
     connectTo
-      nullTracer -- tct
+      tct
       (,)
-      -- (localInitiatorNetworkApplication (tstx, tsr) pInfoConfig tx)
-      (localInitiatorNetworkApplication (nullTracer, nullTracer) pInfoConfig tx)
+      (localInitiatorNetworkApplication (tstx, tsr) pInfoConfig tx)
       Nothing
       addr
-
-    --let txId = Mempool.txId tx
-    putStrLn ("   Tx submitted" :: String)
   where
     addr = localSocketAddrInfo (localSocketFilePath nodeId)
 
@@ -309,6 +318,8 @@ localInitiatorNetworkApplication
      , MonadST m
      , MonadThrow m
      , MonadTimer m
+     , Show (GenTxId blk)
+     , Show (ApplyTxErr blk)
      )
   => ( Tracer m (TraceSubmitTx blk)
      -- ^ benchmarking observables
@@ -329,7 +340,7 @@ localInitiatorNetworkApplication (trtx, trsr) pInfoConfig tx =
   $ OuroborosInitiatorApplication $ \peer ptcl -> case ptcl of
       LocalTxSubmissionPtcl -> \channel -> do
         let trTxId = Mempool.txId tx
-        --traceWith trtx $ TraceSubmitTxStart trTxId tx
+        traceWith trtx $ TraceSubmitTxStart trTxId tx
         result <- runPeer
                     trsr
                     localTxSubmissionCodec
@@ -339,8 +350,8 @@ localInitiatorNetworkApplication (trtx, trsr) pInfoConfig tx =
                        (pure (txSubmissionClientSingle tx)))
 
         case result of
-          Nothing  -> putStrLn ("TX SUMBITTED" :: String) -- traceWith trtx $ TraceSubmitTxSubmitted trTxId
-          Just msg -> putStrLn ("TX REJECTED" :: String) -- traceWith trtx $ TraceSubmitTxRejected trTxId msg
+          Nothing  -> traceWith trtx $ TraceSubmitTxSubmitted trTxId
+          Just msg -> traceWith trtx $ TraceSubmitTxRejected trTxId msg
 
       -- this is just a null implementation, never requests anything.
       ChainSyncWithBlocksPtcl -> \channel ->