Skip to content

Commit

Permalink
network-mux: label various TVar's
Browse files Browse the repository at this point in the history
  • Loading branch information
@coot
coot committed Oct 14, 2021
1 parent b910623 commit 543f629
Show file tree
Hide file tree
Showing 9 changed files with 58 additions and 38 deletions.
2 changes: 2 additions & 0 deletions network-mux/src/Network/Mux.hs
View file
Expand Up @@ -203,6 +203,7 @@ runMux :: forall m mode.
( MonadAsync m
, MonadCatch m
, MonadFork m
, MonadLabelledSTM m
, MonadThrow (STM m)
, MonadTime m
, MonadTimer m
Expand All @@ -214,6 +215,7 @@ runMux :: forall m mode.
-> m ()
runMux tracer Mux {muxMiniProtocols, muxControlCmdQueue, muxStatus} bearer = do
egressQueue <- atomically $ newTBQueue 100
labelTBQueueIO egressQueue "mux-eq"

JobPool.withJobPool
(\jobpool -> do
Expand Down
20 changes: 14 additions & 6 deletions network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs
View file
Expand Up @@ -100,16 +100,24 @@ writeQueueChannel QueueChannel { qcWrite } msg =
>> return True


newConnectedQueueChannelPair :: MonadSTM m
newConnectedQueueChannelPair :: ( MonadSTM m
, MonadLabelledSTM m
)
=> STM m ( QueueChannel m
, QueueChannel m )
newConnectedQueueChannelPair = do
read <- newTQueue
write <- newTQueue
labelTQueue read "qc-queue-read"
labelTQueue write "qc-queue-write"
q <- QueueChannel <$> newTVar (Just read)
<*> newTVar (Just write)
labelTVar (qcRead q) "qc-read"
labelTVar (qcWrite q) "qc-write"
q' <- QueueChannel <$> newTVar (Just write)
<*> newTVar (Just read)
labelTVar (qcRead q') "qc-read'"
labelTVar (qcWrite q') "qc-write'"
return (q, q')


Expand Down Expand Up @@ -247,11 +255,11 @@ newAttenuatedChannel tr Attenuation { aReadAttenuation,
--
newConnectedAttenuatedChannelPair
:: forall m.
( MonadSTM m
, MonadTime m
, MonadTimer m
, MonadThrow m
, MonadThrow (STM m)
( MonadLabelledSTM m
, MonadTime m
, MonadTimer m
, MonadThrow m
, MonadThrow (STM m)
)
=> Tracer m AttenuatedChannelTrace
-> Tracer m AttenuatedChannelTrace
Expand Down
1 change: 1 addition & 0 deletions network-mux/src/Network/Mux/Compat.hs
View file
Expand Up @@ -94,6 +94,7 @@ muxStart
:: forall m mode a b.
( MonadAsync m
, MonadFork m
, MonadLabelledSTM m
, MonadThrow (STM m)
, MonadTime m
, MonadTimer m
Expand Down
19 changes: 12 additions & 7 deletions network-mux/test/Test/Mux.hs
View file
Expand Up @@ -985,6 +985,7 @@ encodeInvalidMuxSDU sdu =
prop_demux_sdu :: forall m.
( MonadAsync m
, MonadFork m
, MonadLabelledSTM m
, MonadMask m
, MonadSay m
, MonadThrow (STM m)
Expand Down Expand Up @@ -1293,6 +1294,7 @@ triggerApp bearer app = do
prop_mux_start_mX :: forall m.
( MonadAsync m
, MonadFork m
, MonadLabelledSTM m
, MonadMask m
, MonadSay m
, MonadThrow (STM m)
Expand Down Expand Up @@ -1338,6 +1340,7 @@ prop_mux_start_mX apps runTime = do
prop_mux_restart_m :: forall m.
( MonadAsync m
, MonadFork m
, MonadLabelledSTM m
, MonadMask m
, MonadSay m
, MonadThrow (STM m)
Expand Down Expand Up @@ -1487,6 +1490,7 @@ prop_mux_restart_m (DummyRestartingInitiatorResponderApps rapps) = do
prop_mux_start_m :: forall m.
( MonadAsync m
, MonadFork m
, MonadLabelledSTM m
, MonadMask m
, MonadSay m
, MonadThrow (STM m)
Expand Down Expand Up @@ -1699,13 +1703,14 @@ withNetworkCtx NetworkCtx { ncSocket, ncClose, ncMuxBearer } k =

close_experiment
:: forall sock acc req resp m.
( MonadAsync m
, MonadFork m
, MonadMask m
, MonadTime m
, MonadTimer m
, MonadThrow (STM m)
, MonadST m
( MonadAsync m
, MonadFork m
, MonadLabelledSTM m
, MonadMask m
, MonadTime m
, MonadTimer m
, MonadThrow (STM m)
, MonadST m
, Serialise req
, Serialise resp
, Eq resp
Expand Down
1 change: 1 addition & 0 deletions ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs
View file
Expand Up @@ -176,6 +176,7 @@ makeConnectionHandler
( MonadAsync m
, MonadCatch m
, MonadFork m
, MonadLabelledSTM m
, MonadThrow (STM m)
, MonadTime m
, MonadTimer m
Expand Down
34 changes: 17 additions & 17 deletions ouroboros-network-framework/src/Simulation/Network/Snocket.hs
View file
Expand Up @@ -125,11 +125,11 @@ dualConnection conn@Connection { connChannelLocal, connChannelRemote } =
}


mkConnection :: ( MonadSTM m
, MonadTime m
, MonadTimer m
, MonadThrow m
, MonadThrow (STM m)
mkConnection :: ( MonadLabelledSTM m
, MonadTime m
, MonadTimer m
, MonadThrow m
, MonadThrow (STM m)
)
=> Tracer m (WithAddr (TestAddress addr)
(SnocketTrace m (TestAddress addr)))
Expand Down Expand Up @@ -271,7 +271,7 @@ noAttenuation = BearerInfo { biConnectionDelay = 0
--
newNetworkState
:: forall m peerAddr.
( MonadSTM m
( MonadLabelledSTM m
, GlobalAddressScheme peerAddr
)
=> Script BearerInfo
Expand Down Expand Up @@ -332,12 +332,12 @@ instance GlobalAddressScheme Int where
--
withSnocket
:: forall m peerAddr a.
( MonadSTM m
, MonadCatch m
, MonadMask m
, MonadTime m
, MonadTimer m
, MonadThrow (STM m)
( MonadLabelledSTM m
, MonadCatch m
, MonadMask m
, MonadTime m
, MonadTimer m
, MonadThrow (STM m)
, GlobalAddressScheme peerAddr
, Ord peerAddr
, Typeable peerAddr
Expand Down Expand Up @@ -521,11 +521,11 @@ data OpenType =
-- should be shared with all nodes in the same network.
--
mkSnocket :: forall m addr.
( MonadSTM m
, MonadThrow (STM m)
, MonadMask m
, MonadTime m
, MonadTimer m
( MonadLabelledSTM m
, MonadThrow (STM m)
, MonadMask m
, MonadTime m
, MonadTimer m
, GlobalAddressScheme addr
, Ord addr
, Show addr
Expand Down
17 changes: 9 additions & 8 deletions ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs
View file
Expand Up @@ -166,14 +166,15 @@ untilSuccess go =

clientServerSimulation
:: forall m payload.
( MonadAsync m
, MonadFork m
, MonadMask m
, MonadSay m
, MonadST m
, MonadThrow (STM m)
, MonadTime m
, MonadTimer m
( MonadAsync m
, MonadFork m
, MonadLabelledSTM m
, MonadMask m
, MonadSay m
, MonadST m
, MonadThrow (STM m)
, MonadTime m
, MonadTimer m

, Serialise payload
, Eq payload
Expand Down
1 change: 1 addition & 0 deletions ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/Handshake/Test.hs
View file
Expand Up @@ -978,6 +978,7 @@ prop_channel_simultaneous_open_sim
:: forall vNumber vData m.
( MonadAsync m
, MonadCatch m
, MonadLabelledSTM m
, MonadMask m
, MonadST m
, MonadThrow (STM m)
Expand Down
1 change: 1 addition & 0 deletions ouroboros-network/test/Test/Mux.hs
View file
Expand Up @@ -82,6 +82,7 @@ demo :: forall m block.
( MonadAsync m
, MonadCatch m
, MonadFork m
, MonadLabelledSTM m
, MonadMask m
, MonadSay m
, MonadST m
Expand Down

0 comments on commit 543f629

Please sign in to comment.