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.

Author: coot

network-mux/src/Network/Mux.hs

@@ -116,7 +116,7 @@ data MuxStatus
 -- | Create a mux handle.
 --
 newMux :: forall (mode :: MuxMode) m.
-          MonadSTM m
+          MonadLabelledSTM m
        => [MiniProtocolInfo mode]
        -- ^ description of protocols run by the mux layer.  Only these protocols
        -- one will be able to execute.
@@ -217,9 +217,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
@@ -248,13 +252,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.

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)

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)

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)

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)

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

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

@@ -205,6 +205,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 }

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