Address review remarks, add retry for PortSpec test

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)

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,31 +63,40 @@ 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
   , startTime :: !UTCTime -- ^ watchdog creation time
   , 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

src/Hedgehog/Extras/Test/Tripwire.hs

@@ -1,61 +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
-  ( 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
 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
+
 

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

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