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.9.0.0 +version: 0.10.0.0 synopsis: Supplemental library for hedgehog description: Supplemental library for hedgehog. category: Test @@ -152,6 +152,7 @@ test-suite hedgehog-extras-test import: base, project-config, + directory, hedgehog, hedgehog-extras, lifted-base, @@ -171,6 +172,7 @@ Hedgehog.Extras.Test.TestExpectFailure Hedgehog.Extras.Test.TestWatchdogSpec Hedgehog.Extras.Test.UnitSpec + Hedgehog.Extras.Test.WorkspaceSpec build-tool-depends: tasty-discover:tasty-discover ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T" diff --git a/src/Hedgehog/Extras/Test/Base.hs b/src/Hedgehog/Extras/Test/Base.hs --- a/src/Hedgehog/Extras/Test/Base.hs +++ b/src/Hedgehog/Extras/Test/Base.hs @@ -6,6 +6,8 @@ ( propertyOnce , workspace + , workspaceWithConfig + , WorkspacePolicy(..) , moduleWorkspace , note @@ -100,15 +102,15 @@ import Control.Exception (IOException) import Control.Exception.Lifted (bracket, bracket_, try) import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, unless, void, when) +import Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, unless, void) import Control.Monad.Catch (MonadCatch) import Control.Monad.Morph (hoist) import Control.Monad.Reader (MonadIO (..), MonadReader (ask)) import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, runResourceT) import Data.Aeson (Result (..)) -import Data.Bool (Bool (..), otherwise, (&&)) +import Data.Bool (Bool (..), otherwise, (||)) import Data.Either (Either (..), either) -import Data.Eq (Eq ((/=))) +import Data.Eq (Eq ((==))) import Data.Foldable (for_) import Data.Function (const, ($), (.)) import Data.Functor ((<$>)) @@ -120,7 +122,6 @@ import Data.Traversable (Traversable) import Data.Tuple (snd) import GHC.Stack -import Hedgehog (MonadTest) import Hedgehog.Extras.Internal.Test.Integration (Integration, IntegrationState (..)) import Hedgehog.Extras.Stock.CallStack (callerModuleName) import Hedgehog.Extras.Stock.Monad (forceM) @@ -148,9 +149,16 @@ import qualified System.Info as IO import qualified System.IO as IO import qualified System.IO.Temp as IO +import Hedgehog.Internal.Property {- HLINT ignore "Reduce duplication" -} +-- | Policy for workspace directory cleanup behavior +data WorkspacePolicy + = PreserveWorkspace -- ^ Always preserve workspace directories, even on success + | CleanupOnSuccess -- ^ Clean up workspace directories only when tests succeed + deriving (Eq, Show) + -- | Run a property with only one test. This is intended for allowing hedgehog -- to run unit tests. propertyOnce :: HasCallStack => Integration () -> H.Property @@ -181,26 +189,64 @@ -- the block fails. workspace :: HasCallStack + => MonadCatch m => MonadBaseControl IO m => MonadResource m => MonadTest m + => H.MonadAssertion m => FilePath -> (FilePath -> m ()) -> m () -workspace prefixPath f = - withFrozenCallStack $ - bracket init fini $ \ws -> do - H.annotate $ "Workspace: " <> ws - H.evalIO $ IO.writeFile (ws "module") callerModuleName - f ws +workspace prefixPath f = withFrozenCallStack $ do + maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE" + let policy = if IO.os == "mingw32" || maybeKeepWorkspace == Just "1" + then PreserveWorkspace + else CleanupOnSuccess + workspaceWithConfig policy prefixPath f + +-- | Create a workspace directory with explicit configuration for cleanup behavior. +-- +-- The directory will have the supplied prefix but contain a generated random +-- suffix to prevent interference between tests +-- +-- The directory will be deleted if the block succeeds, but left behind if +-- the block fails (unless policy is PreserveWorkspace, in which case it's always preserved). +workspaceWithConfig + :: HasCallStack + => MonadCatch m + => MonadBaseControl IO m + => MonadResource m + => MonadTest m + => H.MonadAssertion m + => WorkspacePolicy -- ^ Cleanup policy: PreserveWorkspace always preserves, CleanupOnSuccess deletes on success only + -> FilePath + -> (FilePath -> m ()) + -> m () +workspaceWithConfig policy prefixPath f = withFrozenCallStack $ evalM $ do + ws <- do + systemTemp <- H.evalIO IO.getCanonicalTemporaryDirectory + H.evalIO $ IO.createTempDirectory systemTemp $ prefixPath <> "-test" + + H.annotate $ "Workspace: " <> ws + H.evalIO $ IO.writeFile (ws "module") callerModuleName + + result <- H.catchAssertion (fmap Right (f ws)) (return . Left) + + case result of + Right _ -> do + -- Test succeeded, clean up if policy allows + case policy of + CleanupOnSuccess -> removeWorkspaceRetries ws 20 + PreserveWorkspace -> pure () + Left assertion -> do + -- Test failed, preserve workspace for debugging (unless policy forces cleanup) + case policy of + CleanupOnSuccess -> do + H.annotate $ "Test failed, preserving workspace for debugging: " <> ws + PreserveWorkspace -> pure () + -- Re-throw the original assertion failure + H.throwAssertion assertion where - init = do - systemTemp <- H.evalIO IO.getCanonicalTemporaryDirectory - H.evalIO $ IO.createTempDirectory systemTemp $ prefixPath <> "-test" - fini ws = do - maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE" - when (IO.os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ - removeWorkspaceRetries ws 20 removeWorkspaceRetries :: MonadBaseControl IO m => MonadResource m @@ -233,9 +279,11 @@ -- The 'prefix' argument should not contain directory delimeters. moduleWorkspace :: HasCallStack + => MonadCatch m => MonadBaseControl IO m => MonadResource m => MonadTest m + => H.MonadAssertion m => String -> (FilePath -> m ()) -> m () diff --git a/src/Hedgehog/Extras/Test/TestWatchdog.hs b/src/Hedgehog/Extras/Test/TestWatchdog.hs --- a/src/Hedgehog/Extras/Test/TestWatchdog.hs +++ b/src/Hedgehog/Extras/Test/TestWatchdog.hs @@ -95,40 +95,24 @@ kickWatchdog watchdog pure watchdog -getCallerLocation :: HasCallStack => String -getCallerLocation = - case getCallStack callStack of - (_funcName, _) : (_callerName, callerLoc) : _ -> - srcLocFile callerLoc ++ ":" ++ show (srcLocStartLine callerLoc) - _ -> "" - -- | 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 - :: HasCallStack - => MonadBase IO m - => Watchdog - -> m () -runWatchdog w@Watchdog{watchedThreadId, startTime, kickChan} = - withFrozenCallStack $ 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 - liftIO $ appendFile "/tmp/watchdog.log" $ mconcat - [ "Watchdog: killing thread " <> show watchedThreadId - , " after " <> show (diffUTCTime currentTime startTime) - , "at " <> getCallerLocation - , "\n" - ] - throwTo watchedThreadId . WatchdogException $ diffUTCTime currentTime startTime +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 diff --git a/test/Hedgehog/Extras/Test/WorkspaceSpec.hs b/test/Hedgehog/Extras/Test/WorkspaceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hedgehog/Extras/Test/WorkspaceSpec.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE BangPatterns #-} +module Hedgehog.Extras.Test.WorkspaceSpec where + +import Control.Applicative +import Control.Exception (throwIO) +import Control.Monad.IO.Class +import Data.Bool +import Data.Either +import Data.Function (($)) +import Data.IORef +import Data.Maybe +import Data.Semigroup ((<>)) +import GHC.Err (error) +import Hedgehog +import Hedgehog.Extras.Test.Base +import Hedgehog.Extras.Test.Unit +import System.IO.Error (userError) +import Text.Show + +import qualified System.Directory as IO +import qualified Hedgehog.Internal.Property as H + +-- | Test that workspace directories are removed on successful completion when keepWorkspace=False +tasty_workspace_removed_on_success_on_keepWorkspace_False :: UnitIO () +tasty_workspace_removed_on_success_on_keepWorkspace_False = do + workspacePath <- liftIO $ newIORef Nothing + + -- This workspace operation will succeed + workspaceWithConfig CleanupOnSuccess "test-success" $ \ws -> do + liftIO $ writeIORef workspacePath (Just ws) + -- Successful operation - no failing assertions + True === True + + -- After successful completion, workspace should be removed + maybePath <- liftIO $ readIORef workspacePath + case maybePath of + Nothing -> do + H.failWith Nothing "Expected workspace path to be recorded, but got Nothing" + Just path -> do + exists <- liftIO $ IO.doesDirectoryExist path + annotate $ "Workspace path: " <> path + annotate $ "Directory exists after success: " <> show exists + -- On success, directory should be removed + exists === False + +-- | Test that workspace directories are preserved when assertion fails (keepWorkspace=False) +tasty_workspace_kept_on_assertion_on_keepWorkspace_False :: UnitIO () +tasty_workspace_kept_on_assertion_on_keepWorkspace_False = do + -- This test will intentionally trigger an assertion failure to verify + -- that the workspace directory is preserved for debugging + workspacePath <- liftIO $ newIORef Nothing + + result <- tryAssertion $ workspaceWithConfig CleanupOnSuccess "test-failure" $ \ws -> do + -- Store the workspace path so we can check it later + liftIO $ writeIORef workspacePath (Just ws) + -- Intentionally trigger assertion failure + False === True + + case result of + Left _ -> do + -- Assertion failed as expected, now check if workspace was correctly preserved + maybePath <- liftIO $ readIORef workspacePath + case maybePath of + Nothing -> do + H.failWith Nothing "Expected workspace path to be recorded after failed assertion, but got Nothing" + Just path -> do + exists <- liftIO $ IO.doesDirectoryExist path + -- Correct behavior: directory is preserved on assertion failure for debugging + annotate $ "Workspace path: " <> path + annotate $ "Directory exists: " <> show exists + -- Directory should be preserved when assertion fails + exists === True + -- Clean up manually since assertion failed and we preserved it + liftIO $ IO.removeDirectoryRecursive path + Right _ -> do + -- Assertion unexpectedly passed, this shouldn't happen + annotate "Test was supposed to fail but didn't" + failure + +-- | Test that workspace directories are preserved when pure exception occurs (keepWorkspace=False) +tasty_workspace_kept_on_pure_exception_on_keepWorkspace_False :: UnitIO () +tasty_workspace_kept_on_pure_exception_on_keepWorkspace_False = do + workspacePath <- liftIO $ newIORef Nothing + + result <- tryAssertion $ workspaceWithConfig CleanupOnSuccess "test-pure-exception" $ \ws -> do + -- Store the workspace path so we can check it later + liftIO $ writeIORef workspacePath (Just ws) + -- Force evaluation of pure code that throws an exception + let !_ = error "Pure code exception in workspace" :: () + pure () + + case result of + Left _ -> do + -- Exception was thrown as expected, now check if workspace was correctly preserved + maybePath <- liftIO $ readIORef workspacePath + case maybePath of + Nothing -> + H.failWith Nothing "Expected workspace path to be recorded after pure exception, but got Nothing" + Just path -> do + exists <- liftIO $ IO.doesDirectoryExist path + annotate $ "Workspace path after pure exception: " <> path + annotate $ "Directory exists after pure exception: " <> show exists + -- Correct behavior: directory is preserved when pure code throws exception + exists === True + -- Clean up manually since exception occurred and we preserved it + liftIO $ IO.removeDirectoryRecursive path + Right _ -> do + -- Pure code unexpectedly didn't throw exception + annotate "Pure code was supposed to throw exception but didn't" + failure + +-- | Test that workspace directories are preserved when IO exception occurs (keepWorkspace=False) +tasty_workspace_kept_on_io_exception_on_keepWorkspace_False :: UnitIO () +tasty_workspace_kept_on_io_exception_on_keepWorkspace_False = do + workspacePath <- liftIO $ newIORef Nothing + + result <- tryAssertion $ workspaceWithConfig CleanupOnSuccess "test-io-exception" $ \ws -> do + -- Store the workspace path so we can check it later + liftIO $ writeIORef workspacePath (Just ws) + -- Throw an IO exception within the workspace + liftIO $ throwIO (userError "IO exception in workspace") + + case result of + Left _ -> do + -- Exception was thrown as expected, now check if workspace was correctly preserved + maybePath <- liftIO $ readIORef workspacePath + case maybePath of + Nothing -> + H.failWith Nothing "Expected workspace path to be recorded after IO exception, but got Nothing" + Just path -> do + exists <- liftIO $ IO.doesDirectoryExist path + annotate $ "Workspace path after IO exception: " <> path + annotate $ "Directory exists after IO exception: " <> show exists + -- Correct behavior: directory is preserved when IO exception is thrown + exists === True + -- Clean up manually since exception occurred and we preserved it + liftIO $ IO.removeDirectoryRecursive path + Right _ -> do + -- IO operation unexpectedly didn't throw exception + annotate "IO operation was supposed to throw exception but didn't" + failure + +-- | Test that workspace directories are preserved on successful completion when keepWorkspace=True +tasty_workspace_kept_on_success_on_keepWorkspace_True :: UnitIO () +tasty_workspace_kept_on_success_on_keepWorkspace_True = do + workspacePath <- liftIO $ newIORef Nothing + + -- This workspace operation will succeed + workspaceWithConfig PreserveWorkspace "test-keep-success" $ \ws -> do + liftIO $ writeIORef workspacePath (Just ws) + -- Successful operation - no failing assertions + True === True + + -- After successful completion, workspace should still be preserved due to keepWorkspace=True + maybePath <- liftIO $ readIORef workspacePath + case maybePath of + Nothing -> do + H.failWith Nothing "Expected workspace path to be recorded with keepWorkspace=True, but got Nothing" + Just path -> do + exists <- liftIO $ IO.doesDirectoryExist path + annotate $ "Workspace path with keepWorkspace=True (success): " <> path + annotate $ "Directory exists after success with keepWorkspace=True: " <> show exists + -- With keepWorkspace=True, directory should be preserved even on success + exists === True + -- Clean up manually since we kept it + liftIO $ IO.removeDirectoryRecursive path + +-- | Test that workspace directories are preserved when assertion fails (keepWorkspace=True) +tasty_workspace_kept_on_assertion_on_keepWorkspace_True :: UnitIO () +tasty_workspace_kept_on_assertion_on_keepWorkspace_True = do + workspacePath <- liftIO $ newIORef Nothing + + result <- tryAssertion $ workspaceWithConfig PreserveWorkspace "test-keep" $ \ws -> do + liftIO $ writeIORef workspacePath (Just ws) + -- This assertion will fail, but workspace should be kept due to keepWorkspace=True + False === True + + case result of + Left _ -> do + maybePath <- liftIO $ readIORef workspacePath + case maybePath of + Nothing -> do + H.failWith Nothing "Expected workspace path to be recorded with keepWorkspace=True after failed assertion, but got Nothing" + Just path -> do + exists <- liftIO $ IO.doesDirectoryExist path + annotate $ "Workspace path: " <> path + annotate $ "Directory exists with keepWorkspace=True: " <> show exists + -- With keepWorkspace=True, directory should always be preserved + exists === True + -- Clean up manually since we kept it + liftIO $ IO.removeDirectoryRecursive path + Right _ -> do + annotate "Test was supposed to fail but didn't" + failure + +-- | Test that workspace directories are preserved when pure exception occurs (keepWorkspace=True) +tasty_workspace_kept_on_pure_exception_on_keepWorkspace_True :: UnitIO () +tasty_workspace_kept_on_pure_exception_on_keepWorkspace_True = do + workspacePath <- liftIO $ newIORef Nothing + + result <- tryAssertion $ workspaceWithConfig PreserveWorkspace "test-keep-pure-exception" $ \ws -> do + -- Store the workspace path so we can check it later + liftIO $ writeIORef workspacePath (Just ws) + -- Force evaluation of pure code that throws an exception + let !_ = error "Pure code exception with keepWorkspace=True" :: () + pure () + + case result of + Left _ -> do + -- Exception was thrown as expected, now check if workspace was correctly preserved + maybePath <- liftIO $ readIORef workspacePath + case maybePath of + Nothing -> do + H.failWith Nothing "Expected workspace path to be recorded with keepWorkspace=True after pure exception, but got Nothing" + Just path -> do + exists <- liftIO $ IO.doesDirectoryExist path + annotate $ "Workspace path after pure exception with keepWorkspace=True: " <> path + annotate $ "Directory exists after pure exception with keepWorkspace=True: " <> show exists + -- With keepWorkspace=True, directory should always be preserved + exists === True + -- Clean up manually since we kept it + liftIO $ IO.removeDirectoryRecursive path + Right _ -> do + -- Pure code unexpectedly didn't throw exception + annotate "Pure code was supposed to throw exception but didn't" + failure + +-- | Test that workspace directories are preserved when IO exception occurs (keepWorkspace=True) +tasty_workspace_kept_on_io_exception_on_keepWorkspace_True :: UnitIO () +tasty_workspace_kept_on_io_exception_on_keepWorkspace_True = do + workspacePath <- liftIO $ newIORef Nothing + + result <- tryAssertion $ workspaceWithConfig PreserveWorkspace "test-keep-io-exception" $ \ws -> do + -- Store the workspace path so we can check it later + liftIO $ writeIORef workspacePath (Just ws) + -- Throw an IO exception within the workspace + liftIO $ throwIO (userError "IO exception with keepWorkspace=True") + + case result of + Left _ -> do + -- Exception was thrown as expected, now check if workspace was correctly preserved + maybePath <- liftIO $ readIORef workspacePath + case maybePath of + Nothing -> do + H.failWith Nothing "Expected workspace path to be recorded with keepWorkspace=True after IO exception, but got Nothing" + Just path -> do + exists <- liftIO $ IO.doesDirectoryExist path + annotate $ "Workspace path after IO exception with keepWorkspace=True: " <> path + annotate $ "Directory exists after IO exception with keepWorkspace=True: " <> show exists + -- With keepWorkspace=True, directory should always be preserved + exists === True + -- Clean up manually since we kept it + liftIO $ IO.removeDirectoryRecursive path + Right _ -> do + -- IO operation unexpectedly didn't throw exception + annotate "IO operation was supposed to throw exception but didn't" + failure