diff --git a/src/Hedgehog/Extras/Test/Concurrent.hs b/src/Hedgehog/Extras/Test/Concurrent.hs index 48b630fb..e24720cf 100644 --- a/src/Hedgehog/Extras/Test/Concurrent.hs +++ b/src/Hedgehog/Extras/Test/Concurrent.hs @@ -105,7 +105,7 @@ asyncRegister_ :: HasCallStack => MonadCatch m => IO a -- ^ Action to run in background -> m () -asyncRegister_ act = void . H.evalM $ allocate (async act) cleanUp +asyncRegister_ act = GHC.withFrozenCallStack $ void . H.evalM $ allocate (async act) cleanUp where cleanUp :: Async a -> IO () cleanUp a = cancel a >> void (link a) diff --git a/src/Hedgehog/Extras/Test/TestWatchdog.hs b/src/Hedgehog/Extras/Test/TestWatchdog.hs index e383d6b7..7461106c 100644 --- a/src/Hedgehog/Extras/Test/TestWatchdog.hs +++ b/src/Hedgehog/Extras/Test/TestWatchdog.hs @@ -7,21 +7,40 @@ {-# LANGUAGE TypeApplications #-} -- | This module provides a test watchdog - an utility monitoring test cases and killing them if they don't --- finish in time. To wrap a test case in a watchdog just use +-- 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 +-- runWithWatchdog watchdogConfig $ \\watchdog -> do -- -- body of your test case -- @ +-- module Hedgehog.Extras.Test.TestWatchdog - ( runWithWatchdog_ + ( + -- * Wrap in watchdog + runWithWatchdog_ , runWithWatchdog , runWithDefaultWatchdog_ , runWithDefaultWatchdog - , Watchdog - , WatchdogConfig(..) + + -- * 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) @@ -44,13 +63,13 @@ newtype WatchdogConfig = WatchdogConfig { watchdogTimeout :: Int -- ^ Timeout in seconds after which watchdog will kill the test case } --- | Default watchdog config with 10 minutes timeout. +-- | Default watchdog configuration with 10 minutes timeout. defaultWatchdogConfig :: WatchdogConfig defaultWatchdogConfig = WatchdogConfig { watchdogTimeout = 600 } --- | A watchdog +-- | A watchdog instance. See the module header for more detailed description. data Watchdog = Watchdog { watchdogConfig :: !WatchdogConfig , watchedThreadId :: !ThreadId -- ^ monitored thread id @@ -58,17 +77,26 @@ data Watchdog = Watchdog , kickChan :: TChan WatchdogCommand -- ^ a queue of watchdog commands } --- | Create a new watchdog +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 timeouts expire + -> 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 +-- | 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 () @@ -115,7 +143,7 @@ runWithWatchdog config testCase = do H.withAsync (runWatchdog watchdog) $ \_ -> testCase watchdog --- | Execuate a test case with a watchdog. +-- | Execute a test case with a watchdog. runWithWatchdog_ :: HasCallStack => MonadBaseControl IO m => WatchdogConfig -- ^ configuration diff --git a/src/Hedgehog/Extras/Test/Tripwire.hs b/src/Hedgehog/Extras/Test/Tripwire.hs index 2a8bd564..e53d0546 100644 --- a/src/Hedgehog/Extras/Test/Tripwire.hs +++ b/src/Hedgehog/Extras/Test/Tripwire.hs @@ -1,11 +1,25 @@ +{-# 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 - ( Tripwire + ( + -- * Create a tripwire + Tripwire , makeTripwire - , triggerTripwire + , makeTripwireWithLabel + -- * Tripwire operations + , trip + , trip_ + , isTripped + , getTripSite , resetTripwire - , checkTripwire - , isTriggered + -- * Assertions + , assertNotTripped + , assertTripped ) where import Control.Monad.IO.Class @@ -13,49 +27,102 @@ 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 triggered only once -newtype Tripwire = Tripwire (MVar CallStack) +-- | 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 = Tripwire <$> liftIO newEmptyMVar +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. --- Does not do do anything besides just registering the place where this function is called. -triggerTripwire :: HasCallStack - => MonadIO m - => Tripwire - -> m () -triggerTripwire (Tripwire mv) = withFrozenCallStack $ - void . liftIO $ tryPutMVar mv callStack +-- 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 mv) = liftIO $ void $ tryTakeMVar mv +resetTripwire Tripwire{tripSite} = liftIO $ void $ tryTakeMVar tripSite --- | Check if the tripwire is triggered. Return the first trigger location. -isTriggered :: MonadIO m +-- | Return the call stack, where the tripwire was tripped - if it was tripped. +getTripSite :: MonadIO m => Tripwire -> m (Maybe CallStack) -isTriggered (Tripwire mv) = liftIO $ tryReadMVar mv +getTripSite Tripwire{tripSite} = liftIO $ tryReadMVar tripSite --- | Fails the test if the tripwire was triggered. Prints the callstack where the tripwire was triggered. -checkTripwire :: HasCallStack +-- | 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 () -checkTripwire = withFrozenCallStack $ do - isTriggered >=> void . mapM - (\cs -> do - H.note_ $ "Tripwire has been tripped at: " <> prettyCallStack cs - H.failure - ) +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 index e918b474..cb750da6 100644 --- 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 as H 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 @@ hprop_randomPort = 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 index bb1f63d2..1c6ced88 100644 --- a/test/Hedgehog/Extras/Test/TestWatchdogSpec.hs +++ b/test/Hedgehog/Extras/Test/TestWatchdogSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE LambdaCase #-} module Hedgehog.Extras.Test.TestWatchdogSpec where import Control.Concurrent @@ -32,20 +33,12 @@ hprop_check_watchdog_kills_hanged_thread = H.propertyOnce $ do liftIO $ myThreadId >>= H.putMVar childTid -- simulate thread hang void $ H.threadDelay 3_000_000 - H.triggerTripwire tripwire - - _ <- case result of - 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.assertWith exception $ - isPrefixOf "WatchdogException: " + H.trip tripwire + + assertWatchdogExceptionWasRaised result -- make sure that we didn't trigger the tripwire - H.checkTripwire tripwire + H.assertNotTripped tripwire childStatus <- liftIO $ H.readMVar childTid >>= threadStatus childStatus === ThreadFinished @@ -73,32 +66,25 @@ hprop_check_watchdog_kills_hanged_thread_with_its_children = H.propertyOnce $ do H.asyncRegister_ $ do liftIO $ myThreadId >>= H.putMVar grandChildTid1 threadDelay 3_000_000 - H.triggerTripwire grandChildTripwire1 + H.trip_ grandChildTripwire1 H.asyncRegister_ $ do liftIO $ myThreadId >>= H.putMVar grandChildTid2 threadDelay 3_000_000 - H.triggerTripwire grandChildTripwire2 + H.trip_ grandChildTripwire2 void $ H.threadDelay 3_000_000 - H.triggerTripwire childTripwire - - _ <- case result of - 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.assertWith exception $ - isPrefixOf "WatchdogException: " + 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 - -- make sure that we didn't trigger the tripwire - H.checkTripwire childTripwire - H.checkTripwire grandChildTripwire1 - H.checkTripwire grandChildTripwire2 H.byDeadlineM 0.2 deadline "childStatus" $ do childStatus <- liftIO $ H.readMVar childTid >>= threadStatus @@ -118,6 +104,22 @@ hprop_check_watchdog_kills_hanged_thread_with_its_children = H.propertyOnce $ do tailPid <- liftIO $ H.readMVar procHandle >>= P.getPid tailPid === Nothing +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