diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,18 @@ # Changelog +## [0.19.0.0] - 2024-11-17 + +### Added + +- Timeout support +- `modifiedTimeout` +- `withoutTimeout` +- `withTimeout` + +### Changed + +- Tests now timeout after 60 seconds by default. + ## [0.18.0.1] - 2024-11-01 ### Changed diff --git a/src/Test/Syd.hs b/src/Test/Syd.hs --- a/src/Test/Syd.hs +++ b/src/Test/Syd.hs @@ -179,6 +179,11 @@ withExecutionOrderRandomisation, ExecutionOrderRandomisation (..), + -- *** Modifying the timeout + modifyTimeout, + withoutTimeout, + withTimeout, + -- *** Modifying the number of retries modifyRetries, withoutRetries, diff --git a/src/Test/Syd/Def/Around.hs b/src/Test/Syd/Def/Around.hs --- a/src/Test/Syd/Def/Around.hs +++ b/src/Test/Syd/Def/Around.hs @@ -215,6 +215,7 @@ DefAfterAllNode f sdf -> DefAfterAllNode f $ modifyForest sdf DefParallelismNode f sdf -> DefParallelismNode f $ modifyForest sdf DefRandomisationNode f sdf -> DefRandomisationNode f $ modifyForest sdf + DefTimeoutNode f sdf -> DefTimeoutNode f $ modifyForest sdf DefRetriesNode f sdf -> DefRetriesNode f $ modifyForest sdf DefFlakinessNode f sdf -> DefFlakinessNode f $ modifyForest sdf DefExpectationNode f sdf -> DefExpectationNode f $ modifyForest sdf diff --git a/src/Test/Syd/Modify.hs b/src/Test/Syd/Modify.hs --- a/src/Test/Syd/Modify.hs +++ b/src/Test/Syd/Modify.hs @@ -23,6 +23,11 @@ withExecutionOrderRandomisation, ExecutionOrderRandomisation (..), + -- * Modifying timeouts + modifyTimeout, + withoutTimeout, + withTimeout, + -- * Modifying the number of retries modifyRetries, withoutRetries, @@ -48,6 +53,7 @@ import Control.Monad.RWS.Strict import Test.QuickCheck.IO () import Test.Syd.Def +import Test.Syd.OptParse import Test.Syd.Run import Test.Syd.SpecDef @@ -89,6 +95,18 @@ -- | Annotate a test group with 'ExecutionOrderRandomisation'. withExecutionOrderRandomisation :: ExecutionOrderRandomisation -> TestDefM a b c -> TestDefM a b c withExecutionOrderRandomisation p = censor ((: []) . DefRandomisationNode p) + +-- | Modify the test timeout +modifyTimeout :: (Timeout -> Timeout) -> TestDefM a b c -> TestDefM a b c +modifyTimeout modTimeout = censor ((: []) . DefTimeoutNode modTimeout) + +-- | Turn off timeouts +withoutTimeout :: TestDefM a b c -> TestDefM a b c +withoutTimeout = modifyTimeout (const DoNotTimeout) + +-- | Turn off timeouts +withTimeout :: Int -> TestDefM a b c -> TestDefM a b c +withTimeout i = modifyTimeout (const (TimeoutAfterMicros i)) -- | Modify the number of retries to use in flakiness diagnostics. modifyRetries :: (Word -> Word) -> TestDefM a b c -> TestDefM a b c diff --git a/src/Test/Syd/OptParse.hs b/src/Test/Syd/OptParse.hs --- a/src/Test/Syd/OptParse.hs +++ b/src/Test/Syd/OptParse.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -56,6 +57,8 @@ settingFailFast :: !Bool, -- | How many iterations to use to look diagnose flakiness settingIterations :: !Iterations, + -- | How many microseconds wait for a test to finish before considering it failed + settingTimeout :: !Timeout, -- | How many times to retry a test for flakiness diagnostics settingRetries :: !Word, -- | Whether to fail when any flakiness is detected in tests declared as flaky @@ -123,6 +126,7 @@ ) flagFailFast, settingIterations = flagIterations, + settingTimeout = flagTimeout, settingRetries = fromMaybe ( if flagDebug @@ -152,12 +156,17 @@ settingFilters = mempty, settingFailFast = False, settingIterations = OneIteration, + settingTimeout = TimeoutAfterMicros defaultTimeout, settingRetries = defaultRetries, settingFailOnFlaky = False, settingReportProgress = ReportNoProgress, settingProfile = False } +-- 60 seconds +defaultTimeout :: Int +defaultTimeout = 60_000_000 + defaultRetries :: Word defaultRetries = 3 @@ -196,6 +205,7 @@ flagFailFast :: !(Maybe Bool), flagIterations :: !Iterations, flagRetries :: !(Maybe Word), + flagTimeout :: !Timeout, flagFailOnFlaky :: !Bool, flagReportProgress :: !(Maybe ReportProgress), flagDebug :: !Bool, @@ -293,6 +303,7 @@ name "fail-fast" ] flagIterations <- settingsParser + flagTimeout <- settingsParser flagRetries <- optional $ setting @@ -322,6 +333,39 @@ value $ settingProfile defaultSettings ] pure Flags {..} + +data Timeout + = DoNotTimeout + | TimeoutAfterMicros !Int + deriving (Show, Read, Eq, Generic) + +instance HasCodec Timeout where + codec = dimapCodec f g codec + where + f = \case + Nothing -> DoNotTimeout + Just i -> TimeoutAfterMicros i + g = \case + DoNotTimeout -> Nothing + TimeoutAfterMicros i -> Just i + +instance HasParser Timeout where + settingsParser = + choice + [ setting + [ help "Don't timeout", + switch DoNotTimeout, + long "no-timeout" + ], + TimeoutAfterMicros + <$> setting + [ help "After how many microseconds to consider a test failed", + reader auto, + name "timeout", + value defaultTimeout, + metavar "MICROSECONDS" + ] + ] data Threads = -- | One thread diff --git a/src/Test/Syd/Output.hs b/src/Test/Syd/Output.hs --- a/src/Test/Syd/Output.hs +++ b/src/Test/Syd/Output.hs @@ -604,6 +604,7 @@ DefAroundAllWithNode _ sdf -> goF level sdf DefAfterAllNode _ sdf -> goF level sdf DefParallelismNode _ sdf -> goF level sdf + DefTimeoutNode _ sdf -> goF level sdf DefRetriesNode _ sdf -> goF level sdf DefRandomisationNode _ sdf -> goF level sdf DefFlakinessNode _ sdf -> goF level sdf diff --git a/src/Test/Syd/Runner/Asynchronous.hs b/src/Test/Syd/Runner/Asynchronous.hs --- a/src/Test/Syd/Runner/Asynchronous.hs +++ b/src/Test/Syd/Runner/Asynchronous.hs @@ -191,6 +191,7 @@ noProgressReporter eExternalResources td + eTimeout eRetries eFlakinessMode eExpectationMode @@ -284,6 +285,10 @@ (goForest sdf) DefRandomisationNode _ sdf -> goForest sdf -- Ignore, randomisation has already happened. + DefTimeoutNode modTimeout sdf -> + withReaderT + (\e -> e {eTimeout = modTimeout (eTimeout e)}) + (goForest sdf) DefRetriesNode modRetries sdf -> withReaderT (\e -> e {eRetries = modRetries (eRetries e)}) @@ -301,6 +306,7 @@ (goForest handleForest) Env { eParallelism = Parallel, + eTimeout = settingTimeout settings, eRetries = settingRetries settings, eFlakinessMode = MayNotBeFlaky, eExpectationMode = ExpectPassing, @@ -313,6 +319,7 @@ -- Not exported, on purpose. data Env externalResources = Env { eParallelism :: !Parallelism, + eTimeout :: !Timeout, eRetries :: !Word, eFlakinessMode :: !FlakinessMode, eExpectationMode :: !ExpectationMode, @@ -381,6 +388,7 @@ DefAfterAllNode _ sdf -> fmap SubForestNode <$> goForest sdf DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf + DefTimeoutNode _ sdf -> fmap SubForestNode <$> goForest sdf DefRetriesNode _ sdf -> fmap SubForestNode <$> goForest sdf DefFlakinessNode _ sdf -> fmap SubForestNode <$> goForest sdf DefExpectationNode _ sdf -> fmap SubForestNode <$> goForest sdf @@ -442,6 +450,7 @@ DefAfterAllNode _ sdf -> fmap SubForestNode <$> goForest sdf DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf + DefTimeoutNode _ sdf -> fmap SubForestNode <$> goForest sdf DefRetriesNode _ sdf -> fmap SubForestNode <$> goForest sdf DefFlakinessNode _ sdf -> fmap SubForestNode <$> goForest sdf DefExpectationNode _ sdf -> fmap SubForestNode <$> goForest sdf diff --git a/src/Test/Syd/Runner/Single.hs b/src/Test/Syd/Runner/Single.hs --- a/src/Test/Syd/Runner/Single.hs +++ b/src/Test/Syd/Runner/Single.hs @@ -4,7 +4,9 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE +import System.Timeout (timeout) import Test.Syd.HList +import Test.Syd.OptParse import Test.Syd.Run import Test.Syd.SpecDef @@ -24,6 +26,8 @@ ((HList externalResources -> () -> t) -> t) -> IO TestRunResult ) -> + -- | Timeout + Timeout -> -- | Max retries Word -> -- | Flakiness mode @@ -32,8 +36,8 @@ ExpectationMode -> -- | Test result IO TestRunReport -runSingleTestWithFlakinessMode progressReporter l td maxRetries fm em = do - results <- runSingleTestWithRetries progressReporter l td maxRetries em +runSingleTestWithFlakinessMode progressReporter l td mTimeout maxRetries fm em = do + results <- runSingleTestWithRetries progressReporter l td mTimeout maxRetries em pure TestRunReport { testRunReportExpectationMode = em, @@ -53,24 +57,54 @@ ((HList externalResources -> () -> t) -> t) -> IO TestRunResult ) -> + -- | Timeout + Timeout -> -- | Max retries Word -> -- | Expectation mode ExpectationMode -> -- If the test ever passed, and the last test result IO (NonEmpty TestRunResult) -runSingleTestWithRetries progressReporter l td maxRetries em = go maxRetries +runSingleTestWithRetries progressReporter l td mTimeout maxRetries em = go maxRetries where go :: Word -> IO (NonEmpty TestRunResult) go w - | w <= 1 = (:| []) <$> runFunc + | w <= 1 = (:| []) . either id id <$> runWithTimeout | otherwise = do - result <- runFunc - if testStatusMatchesExpectationMode (testRunResultStatus result) em - then pure (result :| []) - else do - rest <- go (pred w) - pure (result NE.<| rest) + mResult <- runWithTimeout + case mResult of + -- Don't retry on timeout + Left result -> pure (result :| []) + Right result -> + if testStatusMatchesExpectationMode (testRunResultStatus result) em + then pure (result :| []) + else do + rest <- go (pred w) + pure (result NE.<| rest) where + runWithTimeout :: IO (Either TestRunResult TestRunResult) + runWithTimeout = case mTimeout of + DoNotTimeout -> Right <$> runFunc + TimeoutAfterMicros micros -> do + mResult <- timeout micros runFunc + pure $ case mResult of + Nothing -> Left timeoutResult + Just result -> Right result + runFunc :: IO TestRunResult runFunc = testDefVal td progressReporter (\f -> f l ()) + + timeoutResult :: TestRunResult + timeoutResult = + TestRunResult + { testRunResultStatus = TestFailed, + testRunResultException = Nothing, + testRunResultNumTests = Nothing, + testRunResultNumShrinks = Nothing, + testRunResultFailingInputs = [], + testRunResultLabels = Nothing, + testRunResultClasses = Nothing, + testRunResultTables = Nothing, + testRunResultGoldenCase = Nothing, + testRunResultExtraInfo = Just "Timeout!" + } diff --git a/src/Test/Syd/Runner/Synchronous/Interleaved.hs b/src/Test/Syd/Runner/Synchronous/Interleaved.hs --- a/src/Test/Syd/Runner/Synchronous/Interleaved.hs +++ b/src/Test/Syd/Runner/Synchronous/Interleaved.hs @@ -87,6 +87,7 @@ progressReporter eExternalResources td + eTimeout eRetries eFlakinessMode eExpectationMode @@ -155,6 +156,11 @@ liftIO $ fmap SubForestNode <$> (runReaderT (goForest sdf) e `finally` func externalResources) DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, it's synchronous anyway DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, randomisation has already happened. + DefTimeoutNode modTimeout sdf -> + fmap SubForestNode + <$> withReaderT + (\e -> e {eTimeout = modTimeout (eTimeout e)}) + (goForest sdf) DefRetriesNode modRetries sdf -> fmap SubForestNode <$> withReaderT @@ -179,6 +185,7 @@ (goForest testForest) Env { eLevel = 0, + eTimeout = settingTimeout settings, eRetries = settingRetries settings, eFlakinessMode = MayNotBeFlaky, eExpectationMode = ExpectPassing, @@ -205,6 +212,7 @@ -- Not exported, on purpose. data Env externalResources = Env { eLevel :: Int, + eTimeout :: !Timeout, eRetries :: !Word, eFlakinessMode :: !FlakinessMode, eExpectationMode :: !ExpectationMode, diff --git a/src/Test/Syd/Runner/Synchronous/Separate.hs b/src/Test/Syd/Runner/Synchronous/Separate.hs --- a/src/Test/Syd/Runner/Synchronous/Separate.hs +++ b/src/Test/Syd/Runner/Synchronous/Separate.hs @@ -23,7 +23,8 @@ <$> runReaderT (goForest testForest) Env - { eRetries = settingRetries settings, + { eTimeout = settingTimeout settings, + eRetries = settingRetries settings, eFlakinessMode = MayNotBeFlaky, eExpectationMode = ExpectPassing, eExternalResources = HNil @@ -50,6 +51,7 @@ noProgressReporter eExternalResources td + eTimeout eRetries eFlakinessMode eExpectationMode @@ -113,6 +115,11 @@ liftIO $ fmap SubForestNode <$> (runReaderT (goForest sdf) e `finally` func externalResources) DefParallelismNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, it's synchronous anyway DefRandomisationNode _ sdf -> fmap SubForestNode <$> goForest sdf -- Ignore, randomisation has already happened. + DefTimeoutNode modTimeout sdf -> + fmap SubForestNode + <$> withReaderT + (\e -> e {eTimeout = modTimeout (eTimeout e)}) + (goForest sdf) DefRetriesNode modRetries sdf -> fmap SubForestNode <$> withReaderT @@ -133,7 +140,8 @@ -- Not exported, on purpose. data Env externalResources = Env - { eRetries :: !Word, + { eTimeout :: !Timeout, + eRetries :: !Word, eFlakinessMode :: !FlakinessMode, eExpectationMode :: !ExpectationMode, eExternalResources :: !(HList externalResources) diff --git a/src/Test/Syd/SpecDef.hs b/src/Test/Syd/SpecDef.hs --- a/src/Test/Syd/SpecDef.hs +++ b/src/Test/Syd/SpecDef.hs @@ -127,6 +127,11 @@ ExecutionOrderRandomisation -> SpecDefForest outers inner extra -> SpecDefTree outers inner extra + DefTimeoutNode :: + -- | Modify the timeout setting + (Timeout -> Timeout) -> + SpecDefForest outers inner extra -> + SpecDefTree outers inner extra DefRetriesNode :: -- | Modify the number of retries (Word -> Word) -> @@ -161,6 +166,7 @@ DefAfterAllNode func sdf -> DefAfterAllNode func $ goF sdf DefParallelismNode p sdf -> DefParallelismNode p $ goF sdf DefRandomisationNode p sdf -> DefRandomisationNode p $ goF sdf + DefTimeoutNode p sdf -> DefTimeoutNode p $ goF sdf DefRetriesNode p sdf -> DefRetriesNode p $ goF sdf DefFlakinessNode p sdf -> DefFlakinessNode p $ goF sdf DefExpectationNode p sdf -> DefExpectationNode p $ goF sdf @@ -183,6 +189,7 @@ DefAfterAllNode _ sdf -> goF sdf DefParallelismNode _ sdf -> goF sdf DefRandomisationNode _ sdf -> goF sdf + DefTimeoutNode _ sdf -> goF sdf DefRetriesNode _ sdf -> goF sdf DefFlakinessNode _ sdf -> goF sdf DefExpectationNode _ sdf -> goF sdf @@ -205,6 +212,7 @@ DefAfterAllNode func sdf -> DefAfterAllNode func <$> goF sdf DefParallelismNode p sdf -> DefParallelismNode p <$> goF sdf DefRandomisationNode p sdf -> DefRandomisationNode p <$> goF sdf + DefTimeoutNode p sdf -> DefTimeoutNode p <$> goF sdf DefRetriesNode p sdf -> DefRetriesNode p <$> goF sdf DefFlakinessNode p sdf -> DefFlakinessNode p <$> goF sdf DefExpectationNode p sdf -> DefExpectationNode p <$> goF sdf @@ -243,6 +251,7 @@ DefAfterAllNode func sdf -> DefAfterAllNode func <$> goForest dl sdf DefParallelismNode func sdf -> DefParallelismNode func <$> goForest dl sdf DefRandomisationNode func sdf -> DefRandomisationNode func <$> goForest dl sdf + DefTimeoutNode func sdf -> DefTimeoutNode func <$> goForest dl sdf DefRetriesNode func sdf -> DefRetriesNode func <$> goForest dl sdf DefFlakinessNode func sdf -> DefFlakinessNode func <$> goForest dl sdf DefExpectationNode func sdf -> DefExpectationNode func <$> goForest dl sdf @@ -265,6 +274,7 @@ DefAroundAllWithNode func sdf -> DefAroundAllWithNode func <$> goForest sdf DefAfterAllNode func sdf -> DefAfterAllNode func <$> goForest sdf DefParallelismNode func sdf -> DefParallelismNode func <$> goForest sdf + DefTimeoutNode i sdf -> DefTimeoutNode i <$> goForest sdf DefRetriesNode i sdf -> DefRetriesNode i <$> goForest sdf DefFlakinessNode i sdf -> DefFlakinessNode i <$> goForest sdf DefExpectationNode i sdf -> DefExpectationNode i <$> goForest sdf @@ -292,6 +302,7 @@ DefAroundAllWithNode func sdf -> DefAroundAllWithNode func $ goForest sdf DefAfterAllNode func sdf -> DefAfterAllNode func $ goForest sdf DefParallelismNode func sdf -> DefParallelismNode func $ goForest sdf + DefTimeoutNode i sdf -> DefTimeoutNode i $ goForest sdf DefRetriesNode i sdf -> DefRetriesNode i $ goForest sdf DefFlakinessNode i sdf -> DefFlakinessNode i $ goForest sdf DefRandomisationNode eor sdf -> DefRandomisationNode eor (goForest sdf) diff --git a/sydtest.cabal b/sydtest.cabal --- a/sydtest.cabal +++ b/sydtest.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest -version: 0.18.0.1 +version: 0.19.0.0 synopsis: A modern testing framework for Haskell with good defaults and advanced testing features. description: A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category: Testing