Miscellaneous traces

ouroboros-consensus-test/test-consensus/Test/Consensus/MiniProtocol/ChainSync/Client.hs

@@ -366,7 +366,7 @@ runChainSync securityParam (ClientUpdates clientUpdates)
           throwIO ex
       void $ forkLinkedThread registry "ChainSyncServer" $
         runPeer nullTracer codecChainSyncId serverChannel
-                (chainSyncServerPeer server)
+                (chainSyncServerPeer nullTracer server)
 
     LogicalClock.waitUntilDone clock
     -- Wait a random amount of time after the final tick for the chain sync

ouroboros-consensus/src/Ouroboros/Consensus/Network/NodeToClient.hs

@@ -359,7 +359,7 @@ mkApps Tracers {..} Codecs {..} Handlers {..} =
           (contramap (TraceLabelPeer them) tChainSyncTracer)
           cChainSyncCodec
           channel
-          $ chainSyncServerPeer
+          $ chainSyncServerPeer nullTracer
           $ hChainSyncServer registry
 
     aTxSubmissionServer

ouroboros-consensus/src/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -489,7 +489,7 @@ mkApps kernel Tracers {..} Codecs {..} genChainSyncTimeout Handlers {..} =
           (byteLimitsChainSync (const 0)) -- TODO: Real Bytelimits, see #1727
           (timeLimitsChainSync chainSyncTimeout)
           channel
-          $ chainSyncServerPeer
+          $ chainSyncServerPeer nullTracer
           $ hChainSyncServer version registry
 
     aBlockFetchClient
@@ -523,7 +523,7 @@ mkApps kernel Tracers {..} Codecs {..} genChainSyncTimeout Handlers {..} =
           (byteLimitsBlockFetch (const 0)) -- TODO: Real Bytelimits, see #1727
           timeLimitsBlockFetch
           channel
-          $ blockFetchServerPeer
+          $ blockFetchServerPeer nullTracer
           $ hBlockFetchServer version registry
 
     aTxSubmissionClient

ouroboros-network/demo/chain-sync.hs

@@ -207,7 +207,7 @@ serverChainSync sockAddr = withIOManager $ \iocp -> do
       MuxPeer
         (contramap show stdoutTracer)
          codecChainSync
-        (ChainSync.chainSyncServerPeer (chainSyncServer prng))
+        (ChainSync.chainSyncServerPeer nullTracer (chainSyncServer prng))
 
 
 codecChainSync :: ( CBOR.Serialise block
@@ -434,7 +434,7 @@ serverBlockFetch sockAddr = withIOManager $ \iocp -> do
       MuxPeer
         (contramap show stdoutTracer)
          codecChainSync
-        (ChainSync.chainSyncServerPeer (chainSyncServer prng))
+        (ChainSync.chainSyncServerPeer nullTracer (chainSyncServer prng))
 
     blockFetch :: LocalConnectionId
                -> RunMiniProtocol ResponderMode LBS.ByteString IO Void ()
@@ -443,7 +443,7 @@ serverBlockFetch sockAddr = withIOManager $ \iocp -> do
       MuxPeer
         (contramap show stdoutTracer)
          codecBlockFetch
-        (BlockFetch.blockFetchServerPeer (blockFetchServer prng))
+        (BlockFetch.blockFetchServerPeer nullTracer (blockFetchServer prng))
 
 codecBlockFetch :: Codec (BlockFetch.BlockFetch Block (Point Block))
                          CBOR.DeserialiseFailure

ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/BlockFetch/Test.hs

@@ -173,7 +173,7 @@ prop_connect (TestChainAndPoints chain points) =
     case runSimOrThrow
            (connect
              (blockFetchClientPeer (testClient chain points))
-             (blockFetchServerPeer (testServer chain))) of
+             (blockFetchServerPeer nullTracer (testServer chain))) of
       (bodies, (), TerminalStates TokDone TokDone) ->
         reverse bodies == concat (receivedBlockBodies chain points)
 
@@ -190,7 +190,7 @@ connect_pipelined client chain cs = do
     (res, _, TerminalStates TokDone TokDone)
       <- connectPipelined cs
            (blockFetchClientPeerPipelined client)
-           (blockFetchServerPeer (testServer chain))
+           (blockFetchServerPeer nullTracer (testServer chain))
     return $ reverse $ map (fmap reverse) res
 
 
@@ -283,7 +283,7 @@ prop_channel createChannels chain points = do
         createChannels nullTracer
         codec
         (blockFetchClientPeer (testClient chain points))
-        (blockFetchServerPeer (testServer chain))
+        (blockFetchServerPeer nullTracer (testServer chain))
     return $ reverse bodies === concat (receivedBlockBodies chain points)
 
 

ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/ChainSync/Test.hs

@@ -169,15 +169,15 @@ propChainSyncConnectST cps =
     runSimOrThrow $
       chainSyncForkExperiment
         (\ser cli ->
-            void $ connect (chainSyncClientPeer cli) (chainSyncServerPeer ser)
+            void $ connect (chainSyncClientPeer cli) (chainSyncServerPeer nullTracer ser)
         ) cps
 
 propChainSyncConnectIO :: ChainProducerStateForkTest -> Property
 propChainSyncConnectIO cps =
     ioProperty $
       chainSyncForkExperiment
         (\ser cli ->
-            void $  connect (chainSyncClientPeer cli) (chainSyncServerPeer ser)
+            void $  connect (chainSyncClientPeer cli) (chainSyncServerPeer nullTracer ser)
         ) cps
 
 
@@ -275,7 +275,7 @@ propChainSyncPipelinedMaxConnectST cps choices (Positive omax) =
             void $ connectPipelined
               choices
               (chainSyncClientPeerPipelined cli)
-              (chainSyncServerPeer ser)
+              (chainSyncServerPeer nullTracer ser)
         )
         (ChainSyncExamples.chainSyncClientPipelinedMax omax)
         cps
@@ -292,7 +292,7 @@ propChainSyncPipelinedMinConnectST cps choices (Positive omax) =
             void $ connectPipelined
               choices
               (chainSyncClientPeerPipelined cli)
-              (chainSyncServerPeer ser)
+              (chainSyncServerPeer nullTracer ser)
         )
         (ChainSyncExamples.chainSyncClientPipelinedMin omax)
         cps
@@ -308,7 +308,7 @@ propChainSyncPipelinedMaxConnectIO cps choices (Positive omax) =
             void $ connectPipelined
               choices
               (chainSyncClientPeerPipelined cli)
-              (chainSyncServerPeer ser)
+              (chainSyncServerPeer nullTracer ser)
         )
         (ChainSyncExamples.chainSyncClientPipelinedMax omax)
         cps
@@ -324,7 +324,7 @@ propChainSyncPipelinedMinConnectIO cps choices (Positive omax) =
             void $ connectPipelined
               choices
               (chainSyncClientPeerPipelined cli)
-              (chainSyncServerPeer ser)
+              (chainSyncServerPeer nullTracer ser)
         )
         (ChainSyncExamples.chainSyncClientPipelinedMin omax)
         cps
@@ -558,7 +558,7 @@ chainSyncDemo clientChan serverChan (ChainProducerStateForkTest cps chain) = do
       client :: ChainSyncClient Block (Point Block) (Tip Block) m ()
       client = ChainSyncExamples.chainSyncClientExample chainVar (testClient doneVar (Chain.headPoint pchain))
 
-  void $ forkIO (void $ runPeer nullTracer codec serverChan (chainSyncServerPeer server))
+  void $ forkIO (void $ runPeer nullTracer codec serverChan (chainSyncServerPeer nullTracer server))
   void $ forkIO (void $ runPeer nullTracer codec clientChan (chainSyncClientPeer client))
 
   atomically $ do
@@ -626,7 +626,7 @@ chainSyncDemoPipelined clientChan serverChan mkClient (ChainProducerStateForkTes
       client :: ChainSyncClientPipelined Block (Point Block) (Tip Block) m ()
       client = mkClient chainVar (testClient doneVar (Chain.headPoint pchain))
 
-  void $ forkIO (void $ runPeer nullTracer codec serverChan (chainSyncServerPeer server))
+  void $ forkIO (void $ runPeer nullTracer codec serverChan (chainSyncServerPeer nullTracer server))
   void $ forkIO (void $ runPipelinedPeer nullTracer codec clientChan (chainSyncClientPeerPipelined client))
 
   atomically $ do

ouroboros-network/src/Ouroboros/Network/Protocol/BlockFetch/Server.hs

@@ -11,9 +11,9 @@ import Network.TypedProtocol.Core
         , PeerHasAgency (..)
         )
 
+import Control.Tracer (Tracer (..), traceWith)
 import Ouroboros.Network.Protocol.BlockFetch.Type
 
-
 data BlockFetchServer block point m a where
   BlockFetchServer
     :: (ChainRange point -> m (BlockFetchBlockSender block point m a))
@@ -53,10 +53,11 @@ data BlockFetchSendBlocks block point m a where
 
 blockFetchServerPeer
   :: forall block point m a.
-     Functor m
-  => BlockFetchServer block point m a
+     Monad m
+  => Tracer m SendingBlock
+  -> BlockFetchServer block point m a
   -> Peer (BlockFetch block point) AsServer BFIdle m a
-blockFetchServerPeer (BlockFetchServer requestHandler result) =
+blockFetchServerPeer tracer (BlockFetchServer requestHandler result) =
     Await (ClientAgency TokIdle) $ \case
       MsgRequestRange range -> Effect $ sendBatch <$> requestHandler range
       MsgClientDone         -> Done TokDone result
@@ -73,19 +74,21 @@ blockFetchServerPeer (BlockFetchServer requestHandler result) =
   sendBatch (SendMsgNoBlocks next) =
     Yield (ServerAgency TokBusy) MsgNoBlocks $
     Effect $
-      blockFetchServerPeer <$> next
-
+      blockFetchServerPeer tracer <$> next
 
   sendBlocks
     :: BlockFetchSendBlocks block point m a
     -> Peer (BlockFetch block point) AsServer BFStreaming m a
 
   sendBlocks (SendMsgBlock block next') =
     Yield (ServerAgency TokStreaming) (MsgBlock block) $
-    Effect $
+    Effect $ do
+      traceWith tracer SendingBlock
       sendBlocks <$> next'
 
   sendBlocks (SendMsgBatchDone next) =
     Yield (ServerAgency TokStreaming) MsgBatchDone $
     Effect $
-      blockFetchServerPeer <$> next
+      blockFetchServerPeer tracer <$> next
+
+data SendingBlock = SendingBlock

ouroboros-network/src/Ouroboros/Network/Protocol/ChainSync/Server.hs

@@ -26,6 +26,7 @@ module Ouroboros.Network.Protocol.ChainSync.Server  (
     , chainSyncServerPeer
     ) where
 
+import Control.Tracer (Tracer (..), traceWith)
 import Network.TypedProtocol.Core
 
 import Ouroboros.Network.Protocol.ChainSync.Type
@@ -96,9 +97,10 @@ data ServerStIntersect header point tip m a where
 chainSyncServerPeer
   :: forall header point tip m a.
      Monad m
-  => ChainSyncServer header point tip m a
+  => Tracer m SendingHeader
+  -> ChainSyncServer header point tip m a
   -> Peer (ChainSync header point tip) AsServer StIdle m a
-chainSyncServerPeer (ChainSyncServer mterm) = Effect $ mterm >>=
+chainSyncServerPeer tracer (ChainSyncServer mterm) = Effect $ mterm >>=
     \ServerStIdle{recvMsgRequestNext, recvMsgFindIntersect, recvMsgDoneClient} ->
 
     pure $ Await (ClientAgency TokIdle) $ \case
@@ -125,12 +127,14 @@ chainSyncServerPeer (ChainSyncServer mterm) = Effect $ mterm >>=
     handleStNext toknextkind (SendMsgRollForward  header tip next) =
       Yield (ServerAgency (TokNext toknextkind))
             (MsgRollForward header tip)
-            (chainSyncServerPeer next)
+            $ Effect $ do
+                traceWith tracer SendingHeader
+                return $ chainSyncServerPeer tracer next
 
     handleStNext toknextkind (SendMsgRollBackward pIntersect tip next) =
       Yield (ServerAgency (TokNext toknextkind))
             (MsgRollBackward pIntersect tip)
-            (chainSyncServerPeer next)
+            (chainSyncServerPeer tracer next)
 
 
     handleStIntersect
@@ -140,9 +144,11 @@ chainSyncServerPeer (ChainSyncServer mterm) = Effect $ mterm >>=
     handleStIntersect (SendMsgIntersectFound pIntersect tip next) =
       Yield (ServerAgency TokIntersect)
             (MsgIntersectFound pIntersect tip)
-            (chainSyncServerPeer next)
+            (chainSyncServerPeer tracer next)
 
     handleStIntersect (SendMsgIntersectNotFound tip next) =
       Yield (ServerAgency TokIntersect)
             (MsgIntersectNotFound tip)
-            (chainSyncServerPeer next)
+            (chainSyncServerPeer tracer next)
+
+data SendingHeader = SendingHeader

ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs

@@ -329,7 +329,7 @@ runFetchServer :: (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 runFetchServer tracer channel server =
     fst <$>
       runPeerWithLimits tracer codec (byteLimitsBlockFetch (fromIntegral . LBS.length))
-        timeLimitsBlockFetch channel (blockFetchServerPeer server)
+        timeLimitsBlockFetch channel (blockFetchServerPeer nullTracer server)
   where
     codec = codecBlockFetch encode decode encode decode
 

ouroboros-network/test/Ouroboros/Network/MockNode.hs

@@ -290,7 +290,7 @@ relayNode _nid initChain chans = do
   forkRelayKernel upstream cpsVar
 
   -- producers which share @'ChainProducerState'@
-  let producer = chainSyncServerPeer (chainSyncServerExample () cpsVar)
+  let producer = chainSyncServerPeer nullTracer (chainSyncServerExample () cpsVar)
   mapM_ (uncurry $ startProducer producer) (zip [0..] (producerChans chans))
 
   return cpsVar

ouroboros-network/test/Test/Mux.hs

@@ -140,7 +140,7 @@ demo chain0 updates delay = do
 
         producerPeer :: Peer (ChainSync.ChainSync block (Point block) (Tip block))
                         AsServer ChainSync.StIdle m ()
-        producerPeer = ChainSync.chainSyncServerPeer (ChainSync.chainSyncServerExample () producerVar)
+        producerPeer = ChainSync.chainSyncServerPeer nullTracer (ChainSync.chainSyncServerExample () producerVar)
 
     let clientBearer = Mx.queuesAsMuxBearer activeTracer client_w client_r sduLen
         serverBearer = Mx.queuesAsMuxBearer activeTracer server_w server_r sduLen

ouroboros-network/test/Test/Pipe.hs

@@ -182,7 +182,7 @@ demo chain0 updates = do
                         (ChainSync.codecChainSync encode             decode
                                                   encode             decode
                                                   (encodeTip encode) (decodeTip decode))
-                        (ChainSync.chainSyncServerPeer server)
+                        (ChainSync.chainSyncServerPeer nullTracer server)
 
         let clientBearer = Mx.pipeAsMuxBearer activeTracer chan1
             serverBearer = Mx.pipeAsMuxBearer activeTracer chan2

ouroboros-network/test/Test/Socket.hs

@@ -143,7 +143,7 @@ demo chain0 updates = withIOManager $ \iocp -> do
           ResponderProtocolOnly $
             MuxPeer nullTracer
                     codecChainSync
-                    (ChainSync.chainSyncServerPeer server)
+                    (ChainSync.chainSyncServerPeer nullTracer server)
 
         codecChainSync = ChainSync.codecChainSync encode             decode
                                                   encode             decode