From 6528d2da9a1b87042d8cc839c21ebe631363dccc Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 2 Oct 2024 14:16:28 +0200 Subject: [PATCH] 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. --- network-mux/src/Network/Mux.hs | 14 +++++++++----- .../src/Network/Mux/Bearer/AttenuatedChannel.hs | 3 ++- network-mux/src/Network/Mux/Bearer/NamedPipe.hs | 3 ++- network-mux/src/Network/Mux/Bearer/Pipe.hs | 3 ++- network-mux/src/Network/Mux/Bearer/Queues.hs | 3 ++- network-mux/src/Network/Mux/Bearer/Socket.hs | 3 ++- network-mux/src/Network/Mux/Types.hs | 2 ++ .../Test/Ouroboros/Network/ConnectionManager.hs | 3 ++- 8 files changed, 23 insertions(+), 11 deletions(-) diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index fb73554402f..6c8d48e302f 100644 --- 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 index b060c28aad9..87d63782cd6 100644 --- 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 index f4fba4ebd8b..0bbe6775481 100644 --- 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 index 9fe601257e6..1c759dd43d6 100644 --- 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 index 81156268103..ce7ec3edc9b 100644 --- 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 index 6529b0a0b7e..1d0c0185bda 100644 --- 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 index 801a2c63471..b4aa17f052e 100644 --- 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 index baa673a57f9..a682c26e318 100644 --- 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