Add TestWatchdog and Tripwire with their tests

hedgehog-extras.cabal

@@ -131,18 +131,26 @@ library
                         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"

src/Hedgehog/Extras/Test.hs

@@ -2,9 +2,11 @@ module Hedgehog.Extras.Test
   ( 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

src/Hedgehog/Extras/Test/Concurrent.hs

@@ -66,14 +66,17 @@ __Don't use concurrency abstractions from this module, when you need to aggregat
 -}
 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,13 +88,28 @@ import           System.IO (IO)
 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
 

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

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
+
+