label all the things!

Author: ffakenz

hydra-chain-observer/src/Hydra/Blockfrost/ChainObserver.hs

@@ -11,7 +11,6 @@ import Blockfrost.Client (
 import Blockfrost.Client qualified as Blockfrost
 import Control.Concurrent.Class.MonadSTM (
   MonadSTM (readTVarIO),
-  newTVarIO,
   writeTVar,
  )
 import Control.Retry (RetryPolicyM, RetryStatus, constantDelay, retrying)
@@ -96,7 +95,7 @@ blockfrostClient tracer projectPath blockConfirmations = do
 
           let blockHash = fromChainPoint chainPoint genesisBlockHash
 
-          stateTVar <- newTVarIO (blockHash, mempty)
+          stateTVar <- newLabelledTVarIO "blockfrost-client-state" (blockHash, mempty)
           void $
             retrying (retryPolicy blockTime) shouldRetry $ \_ -> do
               loop tracer prj networkId blockTime observerHandler blockConfirmations stateTVar

hydra-cluster/bench/Bench/EndToEnd.hs

@@ -12,8 +12,6 @@ import Control.Concurrent.Class.MonadSTM (
   check,
   lengthTBQueue,
   modifyTVar,
-  newTBQueueIO,
-  newTVarIO,
   tryReadTBQueue,
   writeTBQueue,
   writeTVar,
@@ -83,7 +81,7 @@ bench startingNodeId timeoutSeconds workDir dataset = do
         putTextLn "Starting benchmark"
         let cardanoKeys = hydraNodeKeys dataset <&> \sk -> (getVerificationKey sk, sk)
         let hydraKeys = generateSigningKey . show <$> [1 .. toInteger (length cardanoKeys)]
-        statsTvar <- newTVarIO mempty
+        statsTvar <- newLabelledTVarIO "bench-stats" mempty
         scenarioData <- withOSStats workDir statsTvar $
           withCardanoNodeDevnet (contramap FromCardanoNode tracer) workDir $ \_ backend -> do
             let nodeSocket' = case Backend.getOptions backend of
@@ -261,13 +259,14 @@ withOSStats workDir tvar action =
     Nothing -> action
     Just _ ->
       withCreateProcess process{std_out = CreatePipe} $ \_stdin out _stderr _processHandle ->
-        race
-          ( do
+        raceLabelled
+          ( "os-stats-collect"
+          , do
               -- Write the header
               atomically $ writeTVar tvar [" | Time | Used | Free | ", "|------------------------------------|------|------|"]
               collectStats tvar out
           )
-          action
+          ("os-stats-action", action)
           >>= \case
             Left _ -> failure "dool process failed unexpectedly"
             Right a -> pure a
@@ -384,7 +383,7 @@ processTransactions clients clientDatasets = do
 
   clientProcessDataset (ClientDataset{txSequence}, client) clientId = do
     let numberOfTxs = length txSequence
-    submissionQ <- newTBQueueIO (fromIntegral numberOfTxs)
+    submissionQ <- newLabelledTBQueueIO "submission" (fromIntegral numberOfTxs)
     registry <- newRegistry
     atomically $ forM_ txSequence $ writeTBQueue submissionQ
     ( submitTxs client registry submissionQ
@@ -443,8 +442,8 @@ data Registry tx = Registry
 newRegistry ::
   IO (Registry Tx)
 newRegistry = do
-  processedTxs <- newTVarIO mempty
-  latestSnapshot <- newTVarIO 0
+  processedTxs <- newLabelledTVarIO "registry-processed-txs" mempty
+  latestSnapshot <- newLabelledTVarIO "registry-latest-snapshot" 0
   pure $ Registry{processedTxs, latestSnapshot}
 
 submitTxs ::

hydra-cluster/src/CardanoNode.hs

@@ -322,7 +322,9 @@ withCardanoNode tr stateDirectory args action = do
     withCreateProcess process{std_out = UseHandle out, std_err = CreatePipe} $
       \_stdin _stdout mError processHandle ->
         (`finally` cleanupSocketFile) $
-          race (checkProcessHasNotDied "cardano-node" processHandle mError) waitForNode
+          raceLabelled
+            ("check-cardano-node-process-not-died", checkProcessHasNotDied "cardano-node" processHandle mError)
+            ("wait-for-node", waitForNode)
             <&> either absurd id
  where
   CardanoNodeArgs{nodeSocket} = args

hydra-cluster/src/Hydra/Cluster/Scenarios.hs

@@ -1896,9 +1896,9 @@ threeNodesWithMirrorParty tracer workDir backend hydraScriptsTxId = do
         -- N1 & N3 commit the same thing at the same time
         -- XXX: one will fail but the head will still open
         aliceUTxO <- seedFromFaucet backend aliceCardanoVk 1_000_000 (contramap FromFaucet tracer)
-        race_
-          (requestCommitTx n1 aliceUTxO >>= Backend.submitTransaction backend)
-          (requestCommitTx n3 aliceUTxO >>= Backend.submitTransaction backend)
+        raceLabelled_
+          ("request-commit-tx-n1", requestCommitTx n1 aliceUTxO >>= Backend.submitTransaction backend)
+          ("request-commit-tx-n3", requestCommitTx n3 aliceUTxO >>= Backend.submitTransaction backend)
 
         -- N2 commits something
         bobUTxO <- seedFromFaucet backend bobCardanoVk 1_000_000 (contramap FromFaucet tracer)

hydra-cluster/src/HydraNode.hs

@@ -7,7 +7,7 @@ import Hydra.Prelude hiding (STM, delete)
 
 import CardanoNode (cliQueryProtocolParameters)
 import Control.Concurrent.Async (forConcurrently_)
-import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO)
+import Control.Concurrent.Class.MonadSTM (modifyTVar', readTVarIO)
 import Control.Exception (Handler (..), IOException, catches)
 import Control.Lens ((?~))
 import Control.Monad.Class.MonadAsync (forConcurrently)
@@ -105,7 +105,7 @@ waitNoMatch delay client match = do
 -- | Wait up to some time for an API server output to match the given predicate.
 waitMatch :: HasCallStack => NominalDiffTime -> HydraClient -> (Aeson.Value -> Maybe a) -> IO a
 waitMatch delay client@HydraClient{tracer, hydraNodeId} match = do
-  seenMsgs <- newTVarIO []
+  seenMsgs <- newLabelledTVarIO "wait-match-seen-msgs" []
   timeout (realToFrac delay) (go seenMsgs) >>= \case
     Just x -> pure x
     Nothing -> do
@@ -453,9 +453,9 @@ withPreparedHydraNode tracer workDir hydraNodeId runOptions action =
 
     withProcessTerm cmd $ \p -> do
       -- NOTE: exit code thread gets cancelled if 'action' terminates first
-      race
-        (collectAndCheckExitCode p)
-        (withConnectionToNode tracer hydraNodeId action)
+      raceLabelled
+        ("collect-check-process-exit-code", collectAndCheckExitCode p)
+        ("with-connection-to-node", withConnectionToNode tracer hydraNodeId action)
         <&> either absurd id
  where
   collectAndCheckExitCode p = do

hydra-cluster/test/Test/BlockfrostChainSpec.hs

@@ -6,7 +6,7 @@ import Hydra.Prelude
 import Test.Hydra.Prelude
 
 import Cardano.Api.UTxO qualified as UTxO
-import Control.Concurrent.STM (newEmptyTMVarIO, takeTMVar)
+import Control.Concurrent.STM (takeTMVar)
 import Control.Concurrent.STM.TMVar (putTMVar)
 import Control.Exception (IOException)
 import Hydra.Chain (
@@ -164,7 +164,7 @@ withBlockfrostChainTest tracer config party action = do
           _ -> failure $ "unexpected chainBackendOptions: " <> show chainBackendOptions
       otherConfig -> failure $ "unexpected chainConfig: " <> show otherConfig
   ctx <- loadChainContext backend configuration party
-  eventMVar <- newEmptyTMVarIO
+  eventMVar <- newLabelledEmptyTMVarIO "blockfrost-chain-events"
 
   let callback event = atomically $ putTMVar eventMVar event
 

hydra-cluster/test/Test/ChainObserverSpec.hs

@@ -11,7 +11,7 @@ import Test.Hydra.Prelude
 
 import Cardano.Api.UTxO qualified as UTxO
 import CardanoNode (NodeLog, withCardanoNodeDevnet)
-import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO)
+import Control.Concurrent.Class.MonadSTM (modifyTVar', readTVarIO)
 import Control.Lens ((^?))
 import Data.Aeson as Aeson
 import Data.Aeson.Lens (key, _JSON, _String)
@@ -114,7 +114,7 @@ chainObserverSees observer txType headId =
 
 awaitMatch :: HasCallStack => ChainObserverHandle -> DiffTime -> (Aeson.Value -> Maybe a) -> IO a
 awaitMatch chainObserverHandle delay f = do
-  seenMsgs <- newTVarIO []
+  seenMsgs <- newLabelledTVarIO "await-match-seen-msgs" []
   timeout delay (go seenMsgs) >>= \case
     Just x -> pure x
     Nothing -> do

hydra-cluster/test/Test/DirectChainSpec.hs

@@ -12,7 +12,7 @@ import CardanoClient (
   waitForUTxO,
  )
 import CardanoNode (NodeLog, withCardanoNodeDevnet)
-import Control.Concurrent.STM (newEmptyTMVarIO, takeTMVar)
+import Control.Concurrent.STM (takeTMVar)
 import Control.Concurrent.STM.TMVar (putTMVar)
 import Control.Lens ((<>~))
 import Data.List.Split (splitWhen)
@@ -548,7 +548,7 @@ withDirectChainTest tracer config party action = do
           _ -> failure $ "unexpected chainBackendOptions: " <> show chainBackendOptions
       otherConfig -> failure $ "unexpected chainConfig: " <> show otherConfig
   ctx <- loadChainContext backend configuration party
-  eventMVar <- newEmptyTMVarIO
+  eventMVar <- newLabelledEmptyTMVarIO "direct-chain-events"
 
   let callback event = atomically $ putTMVar eventMVar event
 

hydra-cluster/test/Test/Hydra/Cluster/MithrilSpec.hs

@@ -3,7 +3,7 @@ module Test.Hydra.Cluster.MithrilSpec where
 import Hydra.Prelude
 import Test.Hydra.Prelude
 
-import Control.Concurrent.Class.MonadSTM (newTVarIO, readTVarIO)
+import Control.Concurrent.Class.MonadSTM (readTVarIO)
 import Control.Lens ((^?))
 import Data.Aeson.Lens (key)
 import Hydra.Cluster.Fixture (KnownNetwork (..))
@@ -24,9 +24,9 @@ spec = parallel $ do
       withTempDir ("mithril-download-" <> show network) $ \tmpDir -> do
         let dbPath = tmpDir </> "db"
         doesDirectoryExist dbPath `shouldReturn` False
-        race_
-          (downloadLatestSnapshotTo tracer network tmpDir)
-          (waitForDownload getTraces)
+        raceLabelled_
+          ("download-latest-snapshot-to", downloadLatestSnapshotTo tracer network tmpDir)
+          ("wait-for-download", waitForDownload getTraces)
 
 -- | Wait for the 'StdErr' message to indicate it starts downloading.
 waitForDownload :: HasCallStack => IO [Envelope MithrilLog] -> IO ()
@@ -45,6 +45,6 @@ waitForDownload getTraces = do
 -- traces captured.
 captureTracer :: Text -> IO (Tracer IO a, IO [Envelope a])
 captureTracer namespace = do
-  traces <- newTVarIO []
+  traces <- newLabelledTVarIO "capture-tracer" []
   let tracer = traceInTVar traces namespace
   pure (tracer, readTVarIO traces)

hydra-cluster/test/Test/OfflineChainSpec.hs

@@ -5,7 +5,7 @@ module Test.OfflineChainSpec where
 import Hydra.Prelude
 import Test.Hydra.Prelude
 
-import Control.Concurrent.Class.MonadSTM (modifyTVar', newTChanIO, newTVarIO, readTChan, readTVarIO, writeTChan)
+import Control.Concurrent.Class.MonadSTM (modifyTVar', newTChanIO, readTChan, readTVarIO, writeTChan)
 import Control.Lens ((^?))
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Lens (key, _Number)
@@ -102,7 +102,7 @@ monitorCallbacks = do
 -- XXX: Dry with the other waitMatch utilities
 waitMatch :: (HasCallStack, ToJSON a) => IO a -> DiffTime -> (a -> Maybe b) -> IO b
 waitMatch waitNext seconds match = do
-  seen <- newTVarIO []
+  seen <- newLabelledTVarIO "wait-match-seen" []
   timeout seconds (go seen) >>= \case
     Just x -> pure x
     Nothing -> do