diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for tasty-flaky +## 0.1.2.0 -- 2025-02-10 + +* Add `flakyTestWithRetryAction`. Retry logic can now be based on test results (#1). + ## 0.1.1.0 -- 2024-12-19 * Explicit support and testing for GHC 9.12 diff --git a/src/Test/Tasty/Flaky.hs b/src/Test/Tasty/Flaky.hs --- a/src/Test/Tasty/Flaky.hs +++ b/src/Test/Tasty/Flaky.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | @@ -10,10 +11,11 @@ -- Maintainer : Laurent René de Cotret -- Portability : portable -- --- This module defines a single function, 'flakyTest', to declare a test +-- This module defines a function, 'flakyTest', to declare a test -- which intermittently fails. Flaky tests can be retries using retry policies -- provided by the "Control.Retry" module (from the @retry@ package). -- +-- To dynamically retry based on the result of a test, see 'flakyTestWithRetryAction' instead. -- -- For example, you can retry test cases from @tasty-hunit@ like so: -- @@ -28,8 +30,9 @@ -- if a failure occurs. -- module Test.Tasty.Flaky ( - -- * Test wrapper + -- * Test wrappers flakyTest + , flakyTestWithRetryAction -- * Re-exports -- @@ -58,35 +61,74 @@ -- | A test tree of type @t@, with an associated retry policy data FlakyTest t - = MkFlakyTest (RetryPolicyM IO) t + = MkFlakyTest (RetryStatus -> Result -> IO RetryAction) (RetryPolicyM IO) t +-- | Modify the delay of a RetryPolicy (in microseconds). +-- Does not change whether or not a retry is performed. +modifyRetryPolicyDelay :: Functor m => (Int -> Int) -> RetryPolicyM m -> RetryPolicyM m +modifyRetryPolicyDelay f (RetryPolicyM p) = RetryPolicyM $ \stat -> fmap f <$> p stat + + -- | Mark any test as flaky. -- --- If this test is not successful, it will be retried according to the supplied @'RetryPolicyM' 'IO'@. +-- If this test is not successful, it will be retried according to the supplied @'RetryPolicyM' 'IO'@. -- See "Control.Retry" for documentation on how to specify a @'RetryPolicyM' 'IO'@. -- -- For example, you can retry test cases from @tasty-hunit@ like so: -- -- @ -- import Test.Tasty.HUnit ( testCase ) -- from tasty-hunit --- +-- -- myFlakyTest :: TestTree --- myFlakyTest = 'flakyTest' ('limitRetries' 5 <> 'constantDelay' 1000) $ testCase "some test case" $ do ... +-- myFlakyTest = 'flakyTest' ('limitRetries' 5 <> 'constantDelay' 1000) $ testCase "some test case" $ do ... -- @ -- +-- To dynamically retry based on the result of a test, see 'flakyTestWithRetryAction' instead. flakyTest :: (RetryPolicyM IO) -> TestTree -> TestTree -flakyTest policy (SingleTest name t) = SingleTest name (MkFlakyTest policy t) -flakyTest policy (TestGroup name subtree) = TestGroup name (map (flakyTest policy) subtree) -flakyTest policy (PlusTestOptions modOption t) = PlusTestOptions modOption (flakyTest policy t) -flakyTest policy (WithResource spec f) = WithResource spec (f <&> flakyTest policy) -flakyTest policy (AskOptions f) = AskOptions $ \optionSet -> flakyTest policy (f optionSet) -flakyTest policy (After depType expr t) = After depType expr (flakyTest policy t) +flakyTest = flakyTestWithRetryAction (\_ _ -> pure ConsultPolicy) +-- | Mark any test as flaky. Like 'flakyTest', but allows for overriding retry policies +-- based on test results. Also see 'RetryAction'. +-- +-- For example, if you only want to retry a test if the error message contains @"some error message"@: +-- +-- @ +-- import Test.Tasty.HUnit ( testCase ) -- from tasty-hunit +-- import Data.List ( isInfixOf ) +-- +-- myFlakyTest :: TestTree +-- myFlakyTest +-- = 'flakyTestWithRetryAction' +-- retryAction +-- ('constantDelay' 1000) +-- $ testCase "some test case" $ do ... +-- where +-- retryAction :: 'RetryStatus' -> 'Result' -> IO 'RetryAction' +-- retryAction _ result +-- | "some error message" ``isInfixOf`` show result = pure `ConsultPolicy` +-- | otherwise = pure `DontRetry` +-- @ +-- +-- @since 0.1.2.0 +flakyTestWithRetryAction :: (RetryStatus -> Result -> IO RetryAction) + -> (RetryPolicyM IO) + -> TestTree -> TestTree +flakyTestWithRetryAction retryAction policy = \case + (SingleTest name t) -> SingleTest name (MkFlakyTest retryAction policy t) + (TestGroup name subtree) -> TestGroup name (map go subtree) + (PlusTestOptions modOption t) -> PlusTestOptions modOption (go t) + (WithResource spec f) -> WithResource spec (f <&> go) + (AskOptions f) -> AskOptions $ \optionSet -> go (f optionSet) + (After depType expr t) -> After depType expr (go t) + where + go = flakyTestWithRetryAction retryAction policy + + instance IsTest t => IsTest (FlakyTest t) where run :: IsTest t => OptionSet -> FlakyTest t -> (Progress -> IO ()) -> IO Result - run opts (MkFlakyTest policy test) progressCallback = go defaultRetryStatus + run opts (MkFlakyTest retryAction policy test) progressCallback = go defaultRetryStatus where -- The logic below mimics the `retry` package's Control.Retry.retrying -- with one major difference: we annotate the final result @@ -95,31 +137,38 @@ go :: RetryStatus -> IO Result go status = do result <- run opts test progressCallback - let consultPolicy policy' = do + let done = pure $ annotateResult status result + consultPolicy policy' = do rs <- applyAndDelay policy' status case rs of -- We are done: no more retries - Nothing -> pure $ annotateResult status result + Nothing -> done -- At least one more retry - Just rs' -> do + Just rs' -> do progressCallback (annotateProgress status) go $! rs' if resultSuccessful result - then pure $ annotateResult status result - else consultPolicy policy - + then done + else do + retry <- retryAction status result + case retry of + DontRetry -> done + ConsultPolicy -> consultPolicy policy + ConsultPolicyOverrideDelay delay -> + consultPolicy $ modifyRetryPolicyDelay (const delay) policy + annotateProgress :: RetryStatus -> Progress - annotateProgress status + annotateProgress status -- Recall that `rsIterNumber` starts at 0, so the first attempt is rsIterNumber + 1 = emptyProgress{progressText=mconcat ["Attempt #", show (rsIterNumber status + 1), " failed"]} - + annotateResult :: RetryStatus -> Result -> Result - annotateResult status result + annotateResult status result = result { resultDescription = resultDescription result <> annotate status } where annotate :: RetryStatus -> String - annotate (RetryStatus iternum cumdelay _) + annotate (RetryStatus iternum cumdelay _) | iternum == 0 = "" | otherwise = mconcat [" [", show iternum, " retries, ", show cumdelay, " μs delay]"] diff --git a/tasty-flaky.cabal b/tasty-flaky.cabal --- a/tasty-flaky.cabal +++ b/tasty-flaky.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: tasty-flaky -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Handle flaky Tasty-based tests description: Handle flaky Tasty-based tests, with configuration retry policies. homepage: https://github.com/LaurentRDC/tasty-flaky