diff --git a/hedgehog-extras.cabal b/hedgehog-extras.cabal --- a/hedgehog-extras.cabal +++ b/hedgehog-extras.cabal @@ -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" diff --git a/src/Hedgehog/Extras/Stock/IO/Network/Port.hs b/src/Hedgehog/Extras/Stock/IO/Network/Port.hs --- a/src/Hedgehog/Extras/Stock/IO/Network/Port.hs +++ b/src/Hedgehog/Extras/Stock/IO/Network/Port.hs @@ -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 diff --git a/src/Hedgehog/Extras/Test.hs b/src/Hedgehog/Extras/Test.hs --- a/src/Hedgehog/Extras/Test.hs +++ b/src/Hedgehog/Extras/Test.hs @@ -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 diff --git a/src/Hedgehog/Extras/Test/Concurrent.hs b/src/Hedgehog/Extras/Test/Concurrent.hs --- a/src/Hedgehog/Extras/Test/Concurrent.hs +++ b/src/Hedgehog/Extras/Test/Concurrent.hs @@ -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 diff --git a/src/Hedgehog/Extras/Test/File.hs b/src/Hedgehog/Extras/Test/File.hs --- a/src/Hedgehog/Extras/Test/File.hs +++ b/src/Hedgehog/Extras/Test/File.hs @@ -48,6 +48,7 @@ , appendFileTimeDelta , assertDirectoryMissing + , assertDirectoryExists ) where import Control.Applicative (Applicative (..)) diff --git a/src/Hedgehog/Extras/Test/TestWatchdog.hs b/src/Hedgehog/Extras/Test/TestWatchdog.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/TestWatchdog.hs @@ -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 diff --git a/src/Hedgehog/Extras/Test/Tripwire.hs b/src/Hedgehog/Extras/Test/Tripwire.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/Tripwire.hs @@ -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 + + diff --git a/test/Hedgehog/Extras/Stock/IO/Network/PortSpec.hs b/test/Hedgehog/Extras/Stock/IO/Network/PortSpec.hs --- a/test/Hedgehog/Extras/Stock/IO/Network/PortSpec.hs +++ b/test/Hedgehog/Extras/Stock/IO/Network/PortSpec.hs @@ -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 diff --git a/test/Hedgehog/Extras/Test/TestWatchdogSpec.hs b/test/Hedgehog/Extras/Test/TestWatchdogSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hedgehog/Extras/Test/TestWatchdogSpec.hs @@ -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') + diff --git a/test/hedgehog-extras-test.hs b/test/hedgehog-extras-test.hs --- a/test/hedgehog-extras-test.hs +++ b/test/hedgehog-extras-test.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --hide-successes #-} +{-# OPTIONS_GHC -F -pgmF tasty-discover #-}