block-fetch: label threads in tests

IntersectMBO · Sep 23, 2020 · 8190ac6 · 8190ac6
1 parent c0b050c
commit 8190ac6
Show file tree

Hide file tree

Showing 2 changed files with 63 additions and 29 deletions.
diff --git a/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs
@@ -92,8 +92,14 @@ blockFetchExample0 decisionTracer clientStateTracer clientMsgTracer
                     (blockFetchClient NodeToNodeV_1 controlMessageSTM)
                     (mockBlockFetchServer1 (unanchorFragment candidateChain))
 
-    fetchAsync  <- async $ blockFetch registry blockHeap
-    driverAsync <- async $ driver blockHeap
+    fetchAsync  <- async $ do
+      threadId <- myThreadId
+      labelThread threadId "block-fetch-logic"
+      blockFetch registry blockHeap
+    driverAsync <- async $ do
+      threadId <- myThreadId
+      labelThread threadId "driver"
+      driver blockHeap
 
     -- Order of shutdown here is important for this example: must kill off the
     -- fetch thread before the peer threads.
@@ -190,8 +196,14 @@ blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer
                         (mockBlockFetchServer1 (unanchorFragment candidateChain))
                     | (peerno, candidateChain) <- zip [1..] candidateChains
                     ]
-    fetchAsync  <- async $ blockFetch registry blockHeap
-    driverAsync <- async $ driver blockHeap
+    fetchAsync  <- async $ do
+      threadId <- myThreadId
+      labelThread threadId "block-fetch-logic"
+      blockFetch registry blockHeap
+    driverAsync <- async $ do
+      threadId <- myThreadId
+      labelThread threadId "block-fetch-driver"
+      driver blockHeap
 
     -- Order of shutdown here is important for this example: must kill off the
     -- fetch thread before the peer threads.
@@ -329,7 +341,8 @@ runFetchServer tracer channel server =
 
 runFetchClientAndServerAsync
                :: (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
-                   MonadST m, MonadTime m, MonadTimer m, Ord peerid,
+                   MonadST m, MonadTime m, MonadTimer m,
+                   Ord peerid, Show peerid,
                    Serialise header, Serialise block,
                    Serialise (HeaderHash block),
                    Typeable block,
@@ -349,26 +362,38 @@ runFetchClientAndServerAsync clientTracer serverTracer
                              registry peerid client server = do
     (clientChannel, serverChannel) <- createConnectedChannels
 
-    clientAsync <- async $ runFetchClient
-                             clientTracer
-                             registry peerid
-                             (fromMaybe id (delayChannel <$> clientDelay) clientChannel)
-                             client
-
-    serverAsync <- async $ runFetchServer
-                             serverTracer
-                             (fromMaybe id (delayChannel <$> serverDelay) serverChannel)
-                             server
+    clientAsync <- async $ do
+      threadId <- myThreadId
+      labelThread threadId ("block-fetch-client-" ++ show peerid)
+      runFetchClient
+        clientTracer
+        registry peerid
+        (fromMaybe id (delayChannel <$> clientDelay) clientChannel)
+        client
+
+    serverAsync <- async $ do
+      threadId <- myThreadId
+      labelThread threadId ("block-fetch-server-" ++ show peerid)
+      runFetchServer
+        serverTracer
+        (fromMaybe id (delayChannel <$> serverDelay) serverChannel)
+        server
 
     -- we are tagging messages with the current peerid, not the target
     -- one, this is different than what's intended but it's fine to do that in
     -- these examples;
-    syncClientAsync <- async $ bracketSyncWithFetchClient
-                                 registry peerid
-                                 (forever (threadDelay 1000) >> return ())
-    keepAliveAsync <- async $ bracketKeepAliveClient
-                                 registry peerid
-                                 (\_ -> forever (threadDelay 1000) >> return ())
+    syncClientAsync <- async $ do
+      threadId <- myThreadId
+      labelThread threadId ("registry-" ++ show peerid)
+      bracketSyncWithFetchClient
+        registry peerid
+        (forever (threadDelay 1000) >> return ())
+    keepAliveAsync <- async $ do
+      threadId <- myThreadId
+      labelThread threadId ("keep-alive-" ++ show peerid)
+      bracketKeepAliveClient
+        registry peerid
+        (\_ -> forever (threadDelay 1000) >> return ())
 
     return (clientAsync, serverAsync, syncClientAsync, keepAliveAsync)
 

diff --git a/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs
@@ -634,20 +634,29 @@ prop_terminate (TestChainFork _commonChain forkChain _forkChain) (Delay delay) =
       result <-
         race
           (do
+            threadId <- myThreadId
+            labelThread threadId "control-message"
             let terminateDelay =
                   realToFrac (Chain.length forkChain) * delay / 2
             threadDelay terminateDelay
             atomically (writeTVar controlMessageVar Terminate)
             let awaitDelay = delay * 100
             threadDelay awaitDelay)
-          (blockFetchExample0
-            (contramap TraceFetchDecision       dynamicTracer)
-            (contramap TraceFetchClientState    dynamicTracer)
-            (contramap TraceFetchClientSendRecv dynamicTracer)
-            (Just delay) (Just delay)
-            (readTVar controlMessageVar)
-            (AnchoredFragment.Empty AnchoredFragment.AnchorGenesis)
-            fork')
+          (do
+            threadId <- myThreadId
+            labelThread threadId "block-fetch"
+            blockFetchExample0
+              (contramap TraceFetchDecision       dynamicTracer)
+              (contramap TraceFetchClientState    dynamicTracer)
+              (contramap TraceFetchClientSendRecv dynamicTracer)
+              (Just delay) (Just delay)
+              (readTVar controlMessageVar)
+              (AnchoredFragment.Empty AnchoredFragment.AnchorGenesis)
+              fork')
+      -- `IOSim` on `Windows` is using `defaultRegisterTimeout`.  It does not
+      -- cancel forked threads.   The timeout which leaves running thread comes
+      -- from 'runPipelinedPeerWithLimits'.
+      -- threadDelay 60
       return $ case result of
         Left _ -> False
         Right _ -> True