network-mux: added name field to MuxBearer

It is used to name various shared stm variables. NOTE: we name them when we `runMux`, not when `newMux` is created.
IntersectMBO · Oct 2, 2024 · 6528d2d · 6528d2d
1 parent 5ad882a
commit 6528d2d
Show file tree

Hide file tree

Showing 8 changed files with 23 additions and 11 deletions.
diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs
@@ -114,7 +114,7 @@ data MuxStatus
     | MuxStopped
 
 
-newMux :: MonadSTM m  => MiniProtocolInfos mode -> m (Mux mode m)
+newMux :: MonadLabelledSTM m  => MiniProtocolInfos mode -> m (Mux mode m)
 newMux ptcls = do
     muxMiniProtocols   <- mkMiniProtocolStateMap ptcls
     muxControlCmdQueue <- atomically newTQueue
@@ -211,9 +211,13 @@ runMux :: forall m mode.
        -> Mux mode m
        -> MuxBearer m
        -> m ()
-runMux tracer Mux {muxMiniProtocols, muxControlCmdQueue, muxStatus} bearer = do
+runMux tracer Mux {muxMiniProtocols, muxControlCmdQueue, muxStatus} bearer@MuxBearer {name} = do
     egressQueue <- atomically $ newTBQueue 100
-    labelTBQueueIO egressQueue "mux-eq"
+
+    -- label shared variables
+    labelTBQueueIO egressQueue (name ++ "-mux-egress")
+    labelTVarIO muxStatus (name ++ "-mux-status")
+    labelTQueueIO muxControlCmdQueue (name ++ "-mux-ctrl")
 
     JobPool.withJobPool
       (\jobpool -> do
@@ -242,13 +246,13 @@ runMux tracer Mux {muxMiniProtocols, muxControlCmdQueue, muxStatus} bearer = do
       JobPool.Job (muxer egressQueue bearer)
                   (return . MuxerException)
                   MuxJob
-                  "muxer"
+                  (name ++ "-muxer")
 
     demuxerJob =
       JobPool.Job (demuxer (Map.elems muxMiniProtocols) bearer)
                   (return . DemuxerException)
                   MuxJob
-                  "demuxer"
+                  (name ++ "-demuxer")
 
 miniProtocolJob
   :: forall mode m.

diff --git a/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs b/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs
@@ -262,7 +262,8 @@ attenuationChannelAsMuxBearer sduSize sduTimeout muxTracer chan =
     MuxBearer {
       read    = readMux,
       write   = writeMux,
-      sduSize
+      sduSize,
+      name    = "attenuation-channel"
     }
   where
     readMux :: TimeoutFn m -> m (MuxSDU, Time)

diff --git a/network-mux/src/Network/Mux/Bearer/NamedPipe.hs b/network-mux/src/Network/Mux/Bearer/NamedPipe.hs
@@ -37,7 +37,8 @@ namedPipeAsBearer sduSize tracer h =
     Mx.MuxBearer {
         Mx.read    = readNamedPipe,
         Mx.write   = writeNamedPipe,
-        Mx.sduSize = sduSize
+        Mx.sduSize = sduSize,
+        Mx.name    = "named-pipe"
       }
   where
     readNamedPipe :: Mx.TimeoutFn IO -> IO (Mx.MuxSDU, Time)

diff --git a/network-mux/src/Network/Mux/Bearer/Pipe.hs b/network-mux/src/Network/Mux/Bearer/Pipe.hs
@@ -77,7 +77,8 @@ pipeAsMuxBearer sduSize tracer channel =
       Mx.MuxBearer {
           Mx.read    = readPipe,
           Mx.write   = writePipe,
-          Mx.sduSize = sduSize
+          Mx.sduSize = sduSize,
+          Mx.name    = "pipe"
         }
     where
       readPipe :: Mx.TimeoutFn IO -> IO (Mx.MuxSDU, Time)

diff --git a/network-mux/src/Network/Mux/Bearer/Queues.hs b/network-mux/src/Network/Mux/Bearer/Queues.hs
@@ -42,7 +42,8 @@ queueChannelAsMuxBearer sduSize tracer QueueChannel { writeQueue, readQueue } =
       Mx.MuxBearer {
         Mx.read    = readMux,
         Mx.write   = writeMux,
-        Mx.sduSize = sduSize
+        Mx.sduSize = sduSize,
+        Mx.name    = "queue-channel"
       }
     where
       readMux :: Mx.TimeoutFn m -> m (Mx.MuxSDU, Time)

diff --git a/network-mux/src/Network/Mux/Bearer/Socket.hs b/network-mux/src/Network/Mux/Bearer/Socket.hs
@@ -53,7 +53,8 @@ socketAsMuxBearer sduSize sduTimeout tracer sd =
       Mx.MuxBearer {
         Mx.read    = readSocket,
         Mx.write   = writeSocket,
-        Mx.sduSize = sduSize
+        Mx.sduSize = sduSize,
+        Mx.name    = "socket-bearer"
       }
     where
       hdrLenght = 8

diff --git a/network-mux/src/Network/Mux/Types.hs b/network-mux/src/Network/Mux/Types.hs
@@ -216,6 +216,8 @@ data MuxBearer m = MuxBearer {
     , read    :: TimeoutFn m -> m (MuxSDU, Time)
     -- | Return a suitable MuxSDU payload size.
     , sduSize :: SDUSize
+    -- | Name of the bearer
+    , name    :: String
     }
 
 newtype SDUSize = SDUSize { getSDUSize :: Word16 }

diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs
@@ -345,7 +345,8 @@ makeFDBearer = MakeBearer $ \_ _ _ ->
       return MuxBearer {
           write   = \_ _ -> getMonotonicTime,
           read    = \_ -> forever (threadDelay 3600),
-          sduSize = SDUSize 1500
+          sduSize = SDUSize 1500,
+          name    = "FD"
         }
 
 -- | We only keep exceptions here which should not be handled by the test