network-mux: added trace points

Added some new tracepoints which requires the tracers to be passed to
`Mux.new` rather than `Mux.run`.

Author: coot

network-mux/changelog.d/20251009_105553_coot_dmq_ntc_socket.md

@@ -0,0 +1,7 @@
+### Breaking
+
+- Tracers are now passed to `Network.Mux.new` rather than `Network.Mux.run`.
+- Added new trace points to `Network.Mux.Trace.Trace`:
+  - `NewMux` which logs all `MiniProtocolInfo`s used to create the new `Mux` interface.
+  - `MuxStarting` which logs that `Mux` is starting.
+

network-mux/demo/mux-demo.hs

@@ -121,7 +121,7 @@ server = do
 
 serverWorker :: Bearer IO -> IO ()
 serverWorker bearer = do
-    mux <- Mx.new ptcls
+    mux <- Mx.new Mx.nullTracers ptcls
 
     void $ forkIO $ do
       awaitResult <-
@@ -133,7 +133,7 @@ serverWorker bearer = do
       putStrLn $ "Result: " ++ show result
       Mx.stop mux
 
-    Mx.run Mx.nullTracers mux bearer
+    Mx.run mux bearer
   where
     ptcls :: [MiniProtocolInfo ResponderMode]
     ptcls = [ MiniProtocolInfo {
@@ -181,7 +181,7 @@ client n msg = do
 
 clientWorker :: Mx.Bearer IO -> Int -> String -> IO ()
 clientWorker bearer n msg = do
-    mux <- Mx.new ptcls
+    mux <- Mx.new Mx.nullTracers ptcls
 
     void $ forkIO $ do
       awaitResult <-
@@ -193,7 +193,7 @@ clientWorker bearer n msg = do
       putStrLn $ "Result: " ++ show result
       Mx.stop mux
 
-    Mx.run Mx.nullTracers mux bearer
+    Mx.run mux bearer
   where
     ptcls :: [MiniProtocolInfo Mx.InitiatorMode]
     ptcls = [ MiniProtocolInfo {

network-mux/src/Network/Mux.hs

@@ -99,7 +99,8 @@ data Mux (mode :: Mode) m =
        muxMiniProtocols   :: !(Map (MiniProtocolNum, MiniProtocolDir)
                                    (MiniProtocolState mode m)),
        muxControlCmdQueue :: !(StrictTQueue m (ControlCmd mode m)),
-       muxStatus          :: StrictTVar m Status
+       muxStatus          :: StrictTVar m Status,
+       muxTracers         :: Tracers m
      }
 
 
@@ -127,18 +128,21 @@ stopped Mux { muxStatus } =
 --
 new :: forall (mode :: Mode) m.
        MonadLabelledSTM m
-    => [MiniProtocolInfo mode]
+    => Tracers m
+    -> [MiniProtocolInfo mode]
     -- ^ description of protocols run by the mux layer.  Only these protocols
     -- one will be able to execute.
     -> m (Mux mode m)
-new ptcls = do
+new muxTracers ptcls = do
+    traceWith (tracer_ muxTracers) (TraceNewMux ptcls)
     muxMiniProtocols   <- mkMiniProtocolStateMap ptcls
     muxControlCmdQueue <- atomically newTQueue
     muxStatus <- newTVarIO Ready
     return Mux {
       muxMiniProtocols,
       muxControlCmdQueue,
-      muxStatus
+      muxStatus,
+      muxTracers
     }
 
 mkMiniProtocolStateMap :: MonadSTM m
@@ -224,18 +228,20 @@ run :: forall m (mode :: Mode).
        , MonadTimer m
        , MonadMask m
        )
-    => Tracers m
-    -> Mux mode m
+    => Mux mode m
     -> Bearer m
     -> m ()
-run tracers@TracersI { tracer_,
-                       bearerTracer_
-                     }
-    Mux { muxMiniProtocols,
+run Mux { muxMiniProtocols,
           muxControlCmdQueue,
-          muxStatus
+          muxStatus,
+          muxTracers = tracers@TracersI {
+              tracer_,
+              bearerTracer_
+            }
         }
     bearer@Bearer{name} = do
+
+    traceWith tracer_ TraceStarting
     egressQueue <- atomically $ newTBQueue 100
 
     -- label shared variables
@@ -361,20 +367,6 @@ data ControlCmd mode m =
        !(MiniProtocolAction m)
    | CmdShutdown
 
--- | Strategy how to start a mini-protocol.
---
-data StartOnDemandOrEagerly =
-    -- | Start a mini-protocol promptly.
-    StartEagerly
-    -- | Start a mini-protocol when data is received for the given
-    -- mini-protocol.  Must be used only when initial message is sent by the
-    -- remote side.
-  | StartOnDemand
-    -- | Like `StartOnDemand`, but start a mini-protocol if data is received for
-    -- any mini-protocol set to `StartOnDemand`.
-  | StartOnDemandAny
-  deriving (Eq, Show)
-
 data MiniProtocolAction m where
     MiniProtocolAction :: forall m a.
       { miniProtocolAction :: ByteChannel m -> m (a, Maybe BL.ByteString),
@@ -767,8 +759,13 @@ runMiniProtocol :: forall mode m a.
                 -> StartOnDemandOrEagerly
                 -> (ByteChannel m -> m (a, Maybe BL.ByteString))
                 -> m (STM m (Either SomeException a))
-runMiniProtocol Mux { muxMiniProtocols, muxControlCmdQueue, muxStatus}
-                ptclNum ptclDir startMode protocolAction
+runMiniProtocol Mux { muxMiniProtocols,
+                      muxControlCmdQueue,
+                      muxStatus
+                    }
+                ptclNum ptclDir
+                startMode
+                protocolAction
 
     -- Ensure the mini-protocol is known and get the status var
   | Just ptclState@MiniProtocolState{miniProtocolStatusVar}

network-mux/src/Network/Mux/Trace.hs

@@ -163,6 +163,8 @@ data Trace =
     | TraceStartOnDemandAny MiniProtocolNum MiniProtocolDir
     | TraceStartedOnDemand MiniProtocolNum MiniProtocolDir
     | TraceTerminating MiniProtocolNum MiniProtocolDir
+    | forall mode. TraceNewMux [MiniProtocolInfo mode]
+    | TraceStarting
     | TraceStopping
     | TraceStopped
 
@@ -175,6 +177,8 @@ instance Show Trace where
     show (TraceStartOnDemandAny mid dir) = printf "Preparing to start on any (%s) in %s" (show mid) (show dir)
     show (TraceStartedOnDemand mid dir) = printf "Started on demand (%s) in %s" (show mid) (show dir)
     show (TraceTerminating mid dir) = printf "Terminating (%s) in %s" (show mid) (show dir)
+    show (TraceNewMux infos) = printf "New mux with protocols: %s" (show infos)
+    show TraceStarting = "Mux starting"
     show TraceStopping = "Mux stopping"
     show TraceStopped  = "Mux stoppped"
 

network-mux/src/Network/Mux/Types.hs

@@ -16,6 +16,7 @@ module Network.Mux.Types
   ( MiniProtocolInfo (..)
   , MiniProtocolNum (..)
   , MiniProtocolDirection (..)
+  , StartOnDemandOrEagerly (..)
   , MiniProtocolLimits (..)
   , Mode (..)
   , HasInitiator
@@ -99,6 +100,7 @@ newtype MiniProtocolLimits =
        --
        maximumIngressQueue :: Int
      }
+  deriving Show
 
 -- $interface
 --
@@ -147,6 +149,7 @@ data MiniProtocolInfo (mode :: Mode) =
        miniProtocolCapability :: !(Maybe Int)
        -- ^ capability on which the mini-protocol should run
      }
+  deriving Show
 
 data MiniProtocolDirection (mode :: Mode) where
     InitiatorDirectionOnly :: MiniProtocolDirection InitiatorMode
@@ -156,6 +159,21 @@ data MiniProtocolDirection (mode :: Mode) where
 
 deriving instance Eq (MiniProtocolDirection (mode :: Mode))
 deriving instance Ord (MiniProtocolDirection (mode :: Mode))
+deriving instance Show (MiniProtocolDirection (mode :: Mode))
+
+-- | Strategy how to start a mini-protocol.
+--
+data StartOnDemandOrEagerly =
+    -- | Start a mini-protocol promptly.
+    StartEagerly
+    -- | Start a mini-protocol when data is received for the given
+    -- mini-protocol.  Must be used only when initial message is sent by the
+    -- remote side.
+  | StartOnDemand
+    -- | Like `StartOnDemand`, but start a mini-protocol if data is received for
+    -- any mini-protocol set to `StartOnDemand`.
+  | StartOnDemandAny
+  deriving (Eq, Show)
 
 --
 -- Mux status