replace async with labelled variant

Author: ffakenz

hydra-node/src/Hydra/Node/InputQueue.hs

@@ -9,7 +9,6 @@ import Control.Concurrent.Class.MonadSTM (
   readTQueue,
   writeTQueue,
  )
-import Control.Monad.Class.MonadAsync (async)
 
 -- | The single, required queue in the system from which a hydra head is "fed".
 -- NOTE(SN): this probably should be bounded and include proper logging
@@ -43,7 +42,7 @@ createInputQueue = do
             modifyTVar' nextId succ
       , reenqueue = \delay e -> do
           atomically $ modifyTVar' numThreads succ
-          void . async $ do
+          void . asyncLabelled "input-queue-reenqueue" $ do
             threadDelay delay
             atomically $ do
               modifyTVar' numThreads pred

hydra-node/test/Hydra/BehaviorSpec.hs

@@ -14,7 +14,7 @@ import Control.Concurrent.Class.MonadSTM (
   writeTQueue,
   writeTVar,
  )
-import Control.Monad.Class.MonadAsync (MonadAsync (async), cancel, forConcurrently)
+import Control.Monad.Class.MonadAsync (cancel, forConcurrently)
 import Control.Monad.IOSim (IOSim, runSimTrace, selectTraceEventsDynamic)
 import Data.List ((!!))
 import Data.List qualified as List
@@ -1067,7 +1067,7 @@ simulatedChainAndNetwork initialChainState = do
   nodes <- newLabelledTVarIO "sim-chain-nodes" []
   nextTxId <- newLabelledTVarIO "sim-chain-next-txid" 10000
   localChainState <- newLocalChainState (initHistory initialChainState)
-  tickThread <- async $ simulateTicks nodes localChainState
+  tickThread <- asyncLabelled "sim-chain-tick" $ simulateTicks nodes localChainState
   pure $
     SimulatedChainNetwork
       { connectNode = \draftNode -> do
@@ -1077,7 +1077,7 @@ simulatedChainAndNetwork initialChainState = do
                   , postTx = \tx -> do
                       now <- getCurrentTime
                       -- Only observe "after one block"
-                      void . async $ do
+                      void . asyncLabelled "sim-chain-post-tx" $ do
                         threadDelay blockTime
                         createAndYieldEvent nodes history localChainState $ toOnChainTx now tx
                   , draftCommitTx = \_ -> error "unexpected call to draftCommitTx"

hydra-node/test/Hydra/Model.hs

@@ -26,7 +26,7 @@ import Control.Concurrent.Class.MonadSTM (
   modifyTVar,
   readTVarIO,
  )
-import Control.Monad.Class.MonadAsync (async, cancel, link)
+import Control.Monad.Class.MonadAsync (cancel, link)
 import Data.List (nub, (\\))
 import Data.List qualified as List
 import Data.Map ((!))
@@ -649,8 +649,8 @@ seedWorld seedKeys seedCP futureCommits = do
     let party = deriveParty hsk
         otherParties = filter (/= party) parties
     (testClient, nodeThread) <- lift $ do
-      outputs <- newLabelledTQueueIO ("outputs-" <> shortLabel hsk)
-      messages <- newLabelledTQueueIO ("messages-" <> shortLabel hsk)
+      outputs <- newLabelledTQueueIO ("seed-world-outputs-" <> shortLabel hsk)
+      messages <- newLabelledTQueueIO ("seed-world-messages-" <> shortLabel hsk)
       outputHistory <- newLabelledTVarIO "seed-world-output-history" []
       node <-
         createHydraNode
@@ -666,7 +666,7 @@ seedWorld seedKeys seedCP futureCommits = do
           seedCP
           testDepositPeriod
       let testClient = createTestHydraClient outputs messages outputHistory node
-      nodeThread <- async $ labelThisThread ("node-" <> shortLabel hsk) >> runHydraNode node
+      nodeThread <- asyncLabelled ("seed-world-node-" <> shortLabel hsk) $ runHydraNode node
       link nodeThread
       pure (testClient, nodeThread)
     pushThread nodeThread

hydra-node/test/Hydra/Model/MockChain.hs

@@ -16,7 +16,7 @@ import Control.Concurrent.Class.MonadSTM (
   writeTQueue,
   writeTVar,
  )
-import Control.Monad.Class.MonadAsync (async, link)
+import Control.Monad.Class.MonadAsync (link)
 import Data.Sequence (Seq (Empty, (:|>)))
 import Data.Sequence qualified as Seq
 import Data.Time (secondsToNominalDiffTime)
@@ -99,10 +99,10 @@ mockChainAndNetwork ::
   UTxO ->
   m (SimulatedChainNetwork Tx m)
 mockChainAndNetwork tr seedKeys commits = do
-  nodes <- newLabelledTVarIO "nodes" []
-  queue <- newLabelledTQueueIO "chain-queue"
+  nodes <- newLabelledTVarIO "mock-chain-nodes" []
+  queue <- newLabelledTQueueIO "mock-chain-chain-queue"
   chain <- newLabelledTVarIO "mock-chain-state" (0 :: ChainSlot, 0 :: Natural, Empty, initialUTxO)
-  tickThread <- async (labelThisThread "chain" >> simulateChain nodes chain queue)
+  tickThread <- asyncLabelled "mock-chain-tick" (simulateChain nodes chain queue)
   link tickThread
   pure
     SimulatedChainNetwork

hydra-prelude/src/Hydra/Prelude.hs

@@ -55,6 +55,7 @@ module Hydra.Prelude (
   newLabelledEmptyTMVarIO,
   concurrentlyLabelled,
   concurrentlyLabelled_,
+  asyncLabelled,
   raceLabelled,
   raceLabelled_,
   withAsyncLabelled,
@@ -75,7 +76,7 @@ import Control.Concurrent.Class.MonadSTM.TVar (TVar, readTVar)
 import Control.Exception (IOException)
 import Control.Monad.Class.MonadAsync (
   Async,
-  MonadAsync (concurrently, race, withAsync),
+  MonadAsync (async, concurrently, race, withAsync),
  )
 import Control.Monad.Class.MonadEventlog (
   MonadEventlog,
@@ -372,3 +373,6 @@ concurrentlyLabelled (lblA, mA) (lblB, mB) =
 
 concurrentlyLabelled_ :: (MonadThread m, MonadAsync m) => (String, m a) -> (String, m b) -> m ()
 concurrentlyLabelled_ = (void .) . concurrentlyLabelled
+
+asyncLabelled :: MonadAsync m => String -> m a -> m (Async m a)
+asyncLabelled lbl mA = async $ labelThisThread lbl >> mA

hydraw/app/Main.hs

@@ -2,7 +2,6 @@ module Main where
 
 import Hydra.Prelude
 
-import Control.Monad.Class.MonadAsync (async)
 import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..))
 import Hydra.Network (Host, readHost)
 import Hydra.Painter (Pixel (..), paintPixel, withClient, withClientNoRetry)
@@ -82,7 +81,7 @@ httpApp networkId key host req send =
         Just [x, y, red, green, blue] -> do
           putStrLn $ show (x, y) <> " -> " <> show (red, green, blue)
           -- \| spawn a connection in a new thread
-          void $ async $ withClientNoRetry host $ \cnx ->
+          void $ asyncLabelled "client-paint-pixel" $ withClientNoRetry host $ \cnx ->
             paintPixel networkId key host cnx Pixel{x, y, red, green, blue}
           send $ responseLBS status200 corsHeaders "OK"
         _ ->