hedgehog-extras 0.6.2.0 → 0.6.3.0

raw patch · 10 files changed

+543/−13 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hedgehog-extras.cabal +9/−1
• src/Hedgehog/Extras/Stock/IO/Network/Port.hs +4/−0
• src/Hedgehog/Extras/Test.hs +8/−6
• src/Hedgehog/Extras/Test/Concurrent.hs +19/−1
• src/Hedgehog/Extras/Test/File.hs +1/−0
• src/Hedgehog/Extras/Test/TestWatchdog.hs +175/−0
• src/Hedgehog/Extras/Test/Tripwire.hs +128/−0
• test/Hedgehog/Extras/Stock/IO/Network/PortSpec.hs +11/−4
• test/Hedgehog/Extras/Test/TestWatchdogSpec.hs +187/−0
• test/hedgehog-extras-test.hs +1/−1

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:                   hedgehog-extras-version:                0.6.2.0+version:                0.6.3.0 synopsis:               Supplemental library for hedgehog description:            Supplemental library for hedgehog. category:               Test@@ -131,18 +131,26 @@                         Hedgehog.Extras.Test.MonadAssertion                         Hedgehog.Extras.Test.Network                         Hedgehog.Extras.Test.Process+                        Hedgehog.Extras.Test.TestWatchdog+                        Hedgehog.Extras.Test.Tripwire  test-suite hedgehog-extras-test   import:               base, project-config,                         hedgehog,                         hedgehog-extras,                         network,+                        process,+                        resourcet,                         tasty,                         tasty-hedgehog,+                        transformers,+                        time,   hs-source-dirs:       test   main-is:              hedgehog-extras-test.hs   type:                 exitcode-stdio-1.0    other-modules:        Hedgehog.Extras.Stock.IO.Network.PortSpec+                        Hedgehog.Extras.Test.TestWatchdogSpec    build-tool-depends:   tasty-discover:tasty-discover+  ghc-options:          -threaded -rtsopts "-with-rtsopts=-N -T"

@@ -23,6 +23,8 @@   -> m PortNumber randomPort hostAddress = do   sock <- liftIO $ socket AF_INET Stream defaultProtocol+  -- Allow the port to be reused immediately after the socket is closed+  liftIO $ setSocketOption sock ReuseAddr 1   liftIO $ bind sock $ SockAddrInet defaultPort hostAddress   SockAddrInet port _ <- liftIO $ getSocketName sock   liftIO $ close sock@@ -35,6 +37,7 @@   -> m (ReleaseKey, PortNumber) reserveRandomPort hostAddress = do   sock <- liftIO $ socket AF_INET Stream defaultProtocol+  liftIO $ setSocketOption sock ReuseAddr 1   liftIO $ bind sock $ SockAddrInet defaultPort hostAddress   SockAddrInet port _ <- liftIO $ getSocketName sock   releaseKey <- register $ close sock@@ -48,6 +51,7 @@   -> m Bool portInUse hostAddress pn = do   sock <- liftIO $ socket AF_INET Stream defaultProtocol+  liftIO $ setSocketOption sock ReuseAddr 1   result <- liftIO $ try @SomeException $ bind sock (SockAddrInet pn hostAddress)   liftIO $ close sock   return $ either (const False) (const True) result

@@ -2,9 +2,11 @@   ( module X   ) where -import Hedgehog.Extras.Test.Base as X-import Hedgehog.Extras.Test.Concurrent as X-import Hedgehog.Extras.Test.File as X-import Hedgehog.Extras.Test.MonadAssertion as X-import Hedgehog.Extras.Test.Network as X-import Hedgehog.Extras.Test.Process as X+import           Hedgehog.Extras.Test.Base as X+import           Hedgehog.Extras.Test.Concurrent as X+import           Hedgehog.Extras.Test.File as X+import           Hedgehog.Extras.Test.MonadAssertion as X+import           Hedgehog.Extras.Test.Network as X+import           Hedgehog.Extras.Test.Process as X+import           Hedgehog.Extras.Test.TestWatchdog as X+import           Hedgehog.Extras.Test.Tripwire as X

@@ -66,14 +66,17 @@ -} module Hedgehog.Extras.Test.Concurrent   ( threadDelay+  , asyncRegister_   -- * Re-exports of concurrency abstractions from @lifted-base@   , module Control.Concurrent.Async.Lifted+  , module Control.Concurrent.MVar.Lifted   , module System.Timeout.Lifted   ) where  import           Control.Applicative import           Control.Concurrent.Async.Lifted import qualified Control.Concurrent.Lifted as IO+import           Control.Concurrent.MVar.Lifted import           Control.Monad.Base import           Control.Monad.IO.Class import           Control.Monad.Trans.Control@@ -85,12 +88,27 @@ import           System.Timeout.Lifted import qualified UnliftIO +import           Control.Monad+import           Control.Monad.Catch (MonadCatch)+import           GHC.Stack import           Hedgehog import qualified Hedgehog as H  -- | Delay the thread by 'n' milliseconds.-threadDelay :: (MonadTest m, MonadIO m) => Int -> m ()+threadDelay :: (HasCallStack, MonadTest m, MonadIO m) => Int -> m () threadDelay n = GHC.withFrozenCallStack . H.evalIO $ IO.threadDelay n++-- | Runs an action in background, and registers its cancellation to 'MonadResource'.+asyncRegister_ :: HasCallStack+               => MonadTest m+               => MonadResource m+               => MonadCatch m+               => IO a -- ^ Action to run in background+               -> m ()+asyncRegister_ act = GHC.withFrozenCallStack $ void . H.evalM $ allocate (async act) cleanUp+  where+    cleanUp :: Async a -> IO ()+    cleanUp a = cancel a >> void (link a)  instance MonadBase IO (ResourceT IO) where   liftBase = liftIO

@@ -48,6 +48,7 @@    , appendFileTimeDelta   , assertDirectoryMissing+  , assertDirectoryExists   ) where  import           Control.Applicative (Applicative (..))

@@ -0,0 +1,175 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++-- | This module provides a test watchdog - an utility monitoring test cases and killing them if they don't+-- finish in time. 'Watchdog' thread runs in the background, and after specified timeout, it throws+-- 'WatchdogException' to the target thread. A user is able to 'kickWatchdog', which delays the killing and+-- 'poisonWatchdog' which stops the watchdog.+--+-- To wrap a test case in a watchdog just use+--+-- @+-- runWithWatchdog watchdogConfig $ \\watchdog -> do+--   -- body of your test case+-- @+--+module Hedgehog.Extras.Test.TestWatchdog+  (+  -- * Wrap in watchdog+    runWithWatchdog_+  , runWithWatchdog+  , runWithDefaultWatchdog_+  , runWithDefaultWatchdog++  -- * Watchdog control+  , kickWatchdog+  , poisonWatchdog++  -- * Types+  , Watchdog+  , WatchdogConfig(..)+  , WatchdogException(..)++  -- * Low level API+  -- | There is also a lower-level API available, giving the ability to provide target thread ID, which watchdog+  -- will try to kill.++  , makeWatchdog+  , runWatchdog+  ) where++import           Control.Concurrent (myThreadId, threadDelay, throwTo)+import           Control.Concurrent.STM (atomically)+import           Control.Concurrent.STM.TChan (TChan, newTChanIO, tryReadTChan, writeTChan)+import           Control.Exception (Exception)+import           Control.Monad.IO.Class+import           Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime,+                   nominalDiffTimeToSeconds)+import           GHC.Conc (ThreadId)+import           GHC.Stack++import           Control.Monad.Base (MonadBase (..))+import           Control.Monad.Trans.Control (MonadBaseControl)+import qualified Hedgehog.Extras.Test.Concurrent as H+import           Prelude++-- | Configuration for the watchdog.+newtype WatchdogConfig = WatchdogConfig+  { watchdogTimeout :: Int -- ^ Timeout in seconds after which watchdog will kill the test case+  }++-- | Default watchdog configuration with 10 minutes timeout.+defaultWatchdogConfig :: WatchdogConfig+defaultWatchdogConfig = WatchdogConfig+  { watchdogTimeout = 600+  }++-- | A watchdog instance. See the module header for more detailed description.+data Watchdog = Watchdog+  { watchdogConfig :: !WatchdogConfig+  , watchedThreadId :: !ThreadId -- ^ monitored thread id+  , startTime :: !UTCTime -- ^ watchdog creation time+  , kickChan :: TChan WatchdogCommand -- ^ a queue of watchdog commands+  }++instance Show Watchdog where+  show Watchdog{watchdogConfig=WatchdogConfig{watchdogTimeout}, startTime, watchedThreadId} = mconcat+    [ "Watchdog with timeout ", show watchdogTimeout+    , ", started at ", show startTime+    , ", watching thread ID ", show watchedThreadId+    ]++-- | Create manually a new watchdog, providing the target thread ID. After all watchdog timeouts expire,+-- the target thread will get 'WatchdogException' thrown to it asynchronously (using 'throwTo').+makeWatchdog :: MonadBase IO m+             => WatchdogConfig+             -> ThreadId -- ^ thread id which will get killed after all kicks expire+             -> m Watchdog+makeWatchdog config watchedThreadId' = liftBase $ do+  watchdog <- Watchdog config watchedThreadId' <$> getCurrentTime <*> newTChanIO+  kickWatchdog watchdog+  pure watchdog++-- | Run watchdog in a loop in the current thread. Usually this function should be used with 'H.withAsync'+-- to run it in the background.+runWatchdog :: MonadBase IO m+            => Watchdog+            -> m ()+runWatchdog w@Watchdog{watchedThreadId, startTime, kickChan} = liftBase $ do+  atomically (tryReadTChan kickChan) >>= \case+    Just PoisonPill ->+      -- deactivate watchdog+      pure ()+    Just (Kick timeout) -> do+      -- got a kick, wait for another period+      threadDelay $ timeout * 1_000_000+      runWatchdog w+    Nothing -> do+      -- we are out of scheduled timeouts, kill the monitored thread+      currentTime <- getCurrentTime+      throwTo watchedThreadId . WatchdogException $ diffUTCTime currentTime startTime++-- | Watchdog command+data WatchdogCommand+  = Kick !Int -- ^ Add another delay in seconds+  | PoisonPill -- ^ Stop the watchdog++-- | Enqueue a kick for the watchdog. It will extend the timeout by another one defined in the watchdog+-- configuration.+kickWatchdog :: MonadIO m => Watchdog -> m ()+kickWatchdog Watchdog{watchdogConfig=WatchdogConfig{watchdogTimeout}, kickChan} = liftIO $+  atomically $ writeTChan kickChan (Kick watchdogTimeout)++-- | Enqueue a poison pill for the watchdog. It will stop the watchdog after all timeouts.+poisonWatchdog :: MonadIO m => Watchdog -> m ()+poisonWatchdog Watchdog{kickChan} = liftIO $+  atomically $ writeTChan kickChan PoisonPill+++-- | Execute a test case with a watchdog.+runWithWatchdog :: HasCallStack+                => MonadBaseControl IO m+                => WatchdogConfig -- ^ configuration+                -> (HasCallStack => Watchdog -> m a) -- ^ a test case to be wrapped in watchdog+                -> m a+runWithWatchdog config testCase = do+  watchedThreadId <- liftBase myThreadId+  watchdog <- liftBase $ makeWatchdog config watchedThreadId+  H.withAsync (runWatchdog watchdog) $+    \_ -> testCase watchdog++-- | Execute a test case with a watchdog.+runWithWatchdog_ :: HasCallStack+                 => MonadBaseControl IO m+                 => WatchdogConfig -- ^ configuration+                 -> (HasCallStack => m a) -- ^ a test case to be wrapped in watchdog+                 -> m a+runWithWatchdog_ config testCase = runWithWatchdog config (const testCase)++-- | Execute a test case with watchdog with default config.+runWithDefaultWatchdog :: HasCallStack+                       => MonadBaseControl IO m+                       => (HasCallStack => Watchdog -> m a) -- ^ a test case to be wrapped in watchdog+                       -> m a+runWithDefaultWatchdog = runWithWatchdog defaultWatchdogConfig++-- | Execute a test case with watchdog with default config.+runWithDefaultWatchdog_ :: HasCallStack+                        => MonadBaseControl IO m+                        => (HasCallStack => m a) -- ^ a test case to be wrapped in watchdog+                        -> m a+runWithDefaultWatchdog_ testCase = runWithDefaultWatchdog (const testCase)++-- | An exception thrown to the test case thread.+newtype WatchdogException = WatchdogException { timeElapsed :: NominalDiffTime }++instance Show WatchdogException where+  show WatchdogException{timeElapsed} =+    "WatchdogException: Test watchdog killed test case thread after " <> show @Int (round $ nominalDiffTimeToSeconds timeElapsed) <> " seconds."++instance Exception WatchdogException

@@ -0,0 +1,128 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++-- | This modules provides a tripwire abstraction. You can use tripwire as a detection mechanism if the code+-- path was executed. Trip a tripwire with 'trip' in the place where you'd like to detect if it was+-- reached. The tripwire can then be checked in the other place in the code using for example 'isTripped' or+-- 'assertNotTripped'.+module Hedgehog.Extras.Test.Tripwire+  (+  -- * Create a tripwire+    Tripwire+  , makeTripwire+  , makeTripwireWithLabel+  -- * Tripwire operations+  , trip+  , trip_+  , isTripped+  , getTripSite+  , resetTripwire+  -- * Assertions+  , assertNotTripped+  , assertTripped+  ) where++import           Control.Monad.IO.Class+import           GHC.Stack++import           Control.Concurrent.MVar+import           Control.Monad+import           Data.IORef+import           Data.Maybe+import           Hedgehog (MonadTest)+import qualified Hedgehog.Extras.Test.Base as H+import qualified Hedgehog.Internal.Property as H+import           Prelude+import           System.IO.Unsafe (unsafePerformIO)++-- | Counter used to allocate consecutive IDs to tripwires+tripwireCounter :: IORef Int+tripwireCounter = unsafePerformIO $ newIORef 0+{-# NOINLINE tripwireCounter #-}++-- | Represents a tripwire which can be tripped only once. It can be used to detect if a particular code path+-- was reached.+data Tripwire = Tripwire+  { tripwireId :: !String -- ^ a label for identifying the tripwire+  , tripSite :: MVar CallStack -- ^ call stack of the trip site+  }++instance Show Tripwire where+  show Tripwire{tripwireId} = "Tripwire " <> tripwireId++-- | Creates a new tripwire+makeTripwire :: MonadIO m => m Tripwire+makeTripwire = liftIO $ do+  id' <- atomicModifyIORef' tripwireCounter (join (,) . (+1))+  Tripwire (show id') <$> newEmptyMVar++-- | Creates a new tripwire with a label, which is visible when 'show'ed: @Tripwire mylabel@+makeTripwireWithLabel :: MonadIO m+                      => String+                      -> m Tripwire+makeTripwireWithLabel label = liftIO $ do+  Tripwire label <$> newEmptyMVar++-- | Triggers the tripwire and registers the place of the first trigger. Idempotent.+-- Prints the information in the test log about tripping the tripwire.+trip :: HasCallStack+     => MonadIO m+     => MonadTest m+     => Tripwire+     -> m ()+trip t@Tripwire{tripSite} = withFrozenCallStack $ do+  H.note_ $ show t <> " has been tripped"+  void . liftIO $ tryPutMVar tripSite callStack++-- | Triggers the tripwire and registers the place of the first trigger. Idempotent. A silent variant of+-- 'trip' which does not require 'MonadTest', but also does not log the information about tripping.+trip_ :: HasCallStack+      => MonadIO m+      => Tripwire+      -> m ()+trip_ Tripwire{tripSite} = withFrozenCallStack $ do+  void . liftIO $ tryPutMVar tripSite callStack++-- | Restore tripwire to initial non triggered state+resetTripwire :: MonadIO m+              => Tripwire+              -> m ()+resetTripwire Tripwire{tripSite} = liftIO $ void $ tryTakeMVar tripSite++-- | Return the call stack, where the tripwire was tripped - if it was tripped.+getTripSite :: MonadIO m+            => Tripwire+            -> m (Maybe CallStack)+getTripSite Tripwire{tripSite} = liftIO $ tryReadMVar tripSite++-- | Check if the tripwire was tripped.+isTripped :: MonadIO m+          => Tripwire+          -> m Bool+isTripped Tripwire{tripSite} = liftIO $ not <$> isEmptyMVar tripSite++-- | Fails the test if the tripwire was triggered. Prints the call stack where the tripwire was triggered.+assertNotTripped :: HasCallStack+                 => MonadTest m+                 => MonadIO m+                 => Tripwire+                 -> m ()+assertNotTripped tripwire = withFrozenCallStack $ do+  mTripSite <- getTripSite tripwire+  forM_ mTripSite $ \cs -> do+    H.note_ $ show tripwire <> " has been tripped at: " <> prettyCallStack cs+    H.failure++-- | Fails the test if the tripwire was not triggered yet.+assertTripped :: HasCallStack+              => MonadTest m+              => MonadIO m+              => Tripwire+              -> m ()+assertTripped tripwire = withFrozenCallStack $ do+  mTripSite <- getTripSite tripwire+  when (isNothing mTripSite) $ do+    H.note_ $ show tripwire <> " was not tripped"+    H.failure++

@@ -10,6 +10,9 @@ import qualified Hedgehog.Extras.Stock.IO.Network.Port as IO import qualified Network.Socket as N import           Text.Show+import qualified Data.Time as D+import Control.Monad.IO.Class+import Control.Applicative  hprop_randomPort :: Property hprop_randomPort =@@ -20,7 +23,11 @@      H.note_ $ "Allocated port: " <> show pn -    -- Check that the port is available and can be bound to a socket.-    sock <- H.evalIO $ N.socket N.AF_INET N.Stream N.defaultProtocol-    H.evalIO $ N.bind sock $ N.SockAddrInet pn hostAddress-    H.evalIO $ N.close sock+    -- retry binding for 5 seconds - seems that sometimes OS still marks port as unavailable for a while+    -- after 'randomPort' call+    deadline <- D.addUTCTime 5 <$> liftIO D.getCurrentTime+    H.byDeadlineM 0.2 deadline "try binding to allocated port" $ do+      -- Check that the port is available and can be bound to a socket.+      sock <- H.evalIO $ N.socket N.AF_INET N.Stream N.defaultProtocol+      H.evalIO $ N.bind sock $ N.SockAddrInet pn hostAddress+      H.evalIO $ N.close sock

@@ -0,0 +1,187 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE LambdaCase #-}++module Hedgehog.Extras.Test.TestWatchdogSpec where++import           Control.Concurrent+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Except (runExceptT)+import           Control.Monad.Trans.Resource (ResourceT, runResourceT)+import           Control.Monad.Trans.Writer.Lazy (runWriterT)+import           Data.Function+import           Data.List (isPrefixOf)+import           Data.Time.Clock as D+import           GHC.Conc+import           GHC.Stack+import           Hedgehog (Property, (===))+import qualified Hedgehog as H+import qualified Hedgehog.Extras as H+import qualified Hedgehog.Extras.Stock as H+import           Hedgehog.Extras.Test.TestWatchdog+import qualified Hedgehog.Internal.Property as H+import           Prelude+import qualified System.Process as P++-- | Check that watchdog kills test case which waits without an end+hprop_check_watchdog_kills_hanged_thread :: Property+hprop_check_watchdog_kills_hanged_thread = H.propertyOnce $ do+  let watchdogCfg = WatchdogConfig 1+  childTid <- H.newEmptyMVar+  tripwire <- H.makeTripwire++  (result, _) <- spawnTestT $ runWithWatchdog_ watchdogCfg $ do+    liftIO $ myThreadId >>= H.putMVar childTid+    -- simulate thread hang+    void $ H.threadDelay 3_000_000+    H.trip tripwire++  assertWatchdogExceptionWasRaised result++  -- make sure that we  didn't trigger the tripwire+  H.assertNotTripped tripwire+  childStatus <- liftIO $ H.readMVar childTid >>= threadStatus+  childStatus === ThreadFinished++-- | Check that watchdog kills test case which spawns:+--  - a process waiting forever+--  - a child threads waiting+hprop_check_watchdog_kills_hanged_thread_with_its_children :: Property+hprop_check_watchdog_kills_hanged_thread_with_its_children = H.propertyOnce $ do+  let watchdogCfg = WatchdogConfig 1+  childTid <- H.newEmptyMVar+  grandChildTid1 <- H.newEmptyMVar+  grandChildTid2 <- H.newEmptyMVar+  procHandle <- H.newEmptyMVar+  childTripwire <- H.makeTripwire+  grandChildTripwire1 <- H.makeTripwire+  grandChildTripwire2 <- H.makeTripwire++  (result, _) <- spawnTestT $ runWithWatchdog_ watchdogCfg $ do+    liftIO $ myThreadId >>= H.putMVar childTid++    unless H.isWin32 $ do+      (_, _, _, h, _) <- H.createProcess $ P.shell "tail -f /dev/null"+      H.putMVar procHandle h++    H.asyncRegister_ $ do+      liftIO $ myThreadId >>= H.putMVar grandChildTid1+      threadDelay 3_000_000+      H.trip_ grandChildTripwire1++    H.asyncRegister_ $ do+      liftIO $ myThreadId >>= H.putMVar grandChildTid2+      threadDelay 3_000_000+      H.trip_ grandChildTripwire2++    void $ H.threadDelay 3_000_000+    H.trip childTripwire++  -- make sure that we didn't trigger the tripwire+  H.assertNotTripped childTripwire+  H.assertNotTripped grandChildTripwire1+  H.assertNotTripped grandChildTripwire2++  assertWatchdogExceptionWasRaised result++  -- Give OS 5 seconds to do the process cleanup+  deadline <- D.addUTCTime 5 <$> liftIO D.getCurrentTime++  H.byDeadlineM 0.2 deadline "childStatus" $ do+    childStatus <- liftIO $ H.readMVar childTid >>= threadStatus+    childStatus === ThreadFinished++  H.byDeadlineM 0.2 deadline "grandChildStatus1" $ do+    grandChildStatus1 <- liftIO $ H.readMVar grandChildTid1 >>= threadStatus+    grandChildStatus1 === ThreadFinished++  H.byDeadlineM 0.2 deadline "grandChildStatus2" $ do+    grandChildStatus2 <- liftIO $ H.readMVar grandChildTid2 >>= threadStatus+    grandChildStatus2 === ThreadFinished++  -- check that tail process got killed+  unless H.isWin32 $+    H.byDeadlineM 0.2 deadline "tailPid" $ do+      tailPid <- liftIO $ H.readMVar procHandle >>= P.getPid+      tailPid === Nothing++hprop_check_asyncRegister_finishes_with_test :: Property+hprop_check_asyncRegister_finishes_with_test = H.propertyOnce $ do+  childTid <- H.newEmptyMVar+  grandChildTid1 <- H.newEmptyMVar+  grandChildTid2 <- H.newEmptyMVar+  childTripwire <- H.makeTripwire+  grandChildTripwire1 <- H.makeTripwire+  grandChildTripwire2 <- H.makeTripwire++  -- test that asyncRegister_ gets killed when the main thread finishes+  (result, _) <- spawnTestT $ do+    liftIO $ myThreadId >>= H.putMVar childTid++    H.asyncRegister_ $ do+      liftIO $ myThreadId >>= H.putMVar grandChildTid1+      threadDelay 10_000_000+      H.trip_ grandChildTripwire1++    H.asyncRegister_ $ do+      liftIO $ myThreadId >>= H.putMVar grandChildTid2+      threadDelay 10_000_000+      H.trip_ grandChildTripwire2++    H.trip_ childTripwire++  result === Right ()+  -- double check that main thread finished successfully+  H.assertTripped childTripwire+  H.assertNotTripped grandChildTripwire1+  H.assertNotTripped grandChildTripwire2++  -- Give OS 5 seconds to do the process cleanup+  deadline <- D.addUTCTime 5 <$> liftIO D.getCurrentTime++  H.byDeadlineM 0.2 deadline "childStatus" $ do+    childStatus <- liftIO $ H.readMVar childTid >>= threadStatus+    childStatus === ThreadFinished++  H.byDeadlineM 0.2 deadline "grandChildStatus1" $ do+    grandChildStatus1 <- liftIO $ H.readMVar grandChildTid1 >>= threadStatus+    grandChildStatus1 === ThreadFinished++  H.byDeadlineM 0.2 deadline "grandChildStatus2" $ do+    grandChildStatus2 <- liftIO $ H.readMVar grandChildTid2 >>= threadStatus+    grandChildStatus2 === ThreadFinished+++assertWatchdogExceptionWasRaised :: HasCallStack+                                 => H.MonadTest m+                                 => MonadFail m+                                 => Either H.Failure a+                                 -> m ()+assertWatchdogExceptionWasRaised = withFrozenCallStack $ \case+  Right _ -> do+    H.note_ "Expected failure instead of Right"+    H.failure+  Left (H.Failure _ msg _) -> do+    -- check we've failed because of watchdog+    _header:exception:_ <- pure $ lines msg+    H.note_ $ "Received exception:"+    H.assertWith exception $+      isPrefixOf "WatchdogException: "+++-- | Spawn TestT in an async. Waits for the async and logs the result as well as errors journal on failure+spawnTestT :: HasCallStack+         => H.MonadTest m+         => MonadIO m+         => Show a+         => H.TestT (ResourceT IO) a+         -> m (Either H.Failure a, H.Journal)+spawnTestT testt = withFrozenCallStack $ do+  (res, log') <- H.evalIO $+    H.withAsync+      (runResourceT . runWriterT . runExceptT $ H.unTest testt)+      H.wait+  H.noteShow_ res+  H.noteShow_ log'+  pure (res, log')+

@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --hide-successes #-}+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}