diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for tasty-flaky + +## 0.1.0.0 -- 2024-09-24 + +* First version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2024, Laurent Rene de Cotret + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# `tasty-flaky` + +This provides [`tasty`](https://hackage.haskell.org/package/tasty) integration for flaky tests, which are tests that are known to fail intermittently. + +## Example usage + +This package provides a single function, `flakyTest`, which can attach retrying logic to *any* test. +For example, you can retry test cases from [`tasty-hunit`](https://hackage.haskell.org/package/tasty-hunit) like so: + +```haskell +import Test.Tasty.HUnit ( testCase ) -- from tasty-hunit + +myFlakyTest :: TestTree +myFlakyTest + = flakyTest (limitRetries 5 <> constantDelay 1000) + $ testCase "some test case" + $ do ... +``` + +In the example above, the test will be retried up to 5 times, with a delay of 1000 microseconds between tries, +if a failure occurs. diff --git a/src/Test/Tasty/Flaky.hs b/src/Test/Tasty/Flaky.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Flaky.hs @@ -0,0 +1,128 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : $module +-- Copyright : (c) Powerweave Inc. +-- License : BSD-3-Clause +-- Maintainer : Laurent René de Cotret +-- Portability : portable +-- +-- This module defines a single 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). +-- +-- +-- 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 ... +-- @ +-- +-- In the example above, the test will be retried up to 5 times, with a delay of 1000 microseconds between tries, +-- if a failure occurs. +-- +module Test.Tasty.Flaky ( + -- * Test wrapper + flakyTest + + -- * Re-exports + -- + -- | The following functions allow to construct 'RetryPolicyM IO' + -- from the "Control.Retry" module. + , constantDelay + , exponentialBackoff + , fullJitterBackoff + , fibonacciBackoff + , limitRetries + + -- * Policy Transformers + , limitRetriesByDelay + , limitRetriesByCumulativeDelay + , capDelay + +) where + +import Control.Retry hiding (RetryPolicy) +import Data.Functor ( (<&>) ) +import Data.Tagged (Tagged, retag ) +import Test.Tasty.Providers ( IsTest(..), Progress, Result, TestTree ) +import Test.Tasty.Runners ( TestTree(..), Result(..), Progress(..), emptyProgress, resultSuccessful ) +import Test.Tasty.Options ( OptionDescription, OptionSet ) + + +-- | A test tree of type @t@, with an associated retry policy +data FlakyTest t + = MkFlakyTest (RetryPolicyM IO) t + + +-- | Mark any test as flaky. +-- +-- 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 ... +-- @ +-- +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) + + +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 + where + -- The logic below mimics the `retry` package's Control.Retry.retrying + -- with one major difference: we annotate the final result + -- to report how many retries have been performed, regardless of + -- the final result. + go :: RetryStatus -> IO Result + go status = do + result <- run opts test progressCallback + let consultPolicy policy' = do + rs <- applyAndDelay policy' status + case rs of + -- We are done: no more retries + Nothing -> pure $ annotateResult status result + -- At least one more retry + Just rs' -> do + progressCallback (annotateProgress status) + go $! rs' + + if resultSuccessful result + then pure $ annotateResult status result + else consultPolicy policy + + annotateProgress :: RetryStatus -> Progress + 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 + = result { resultDescription = resultDescription result <> annotate status } + where + annotate :: RetryStatus -> String + annotate (RetryStatus iternum cumdelay _) + | iternum == 0 = "" + | otherwise = mconcat [" [", show iternum, " retries, ", show cumdelay, " μs delay]"] + + + testOptions :: Tagged (FlakyTest t) [OptionDescription] + testOptions = retag (testOptions :: Tagged t [OptionDescription]) diff --git a/tasty-flaky.cabal b/tasty-flaky.cabal new file mode 100644 --- /dev/null +++ b/tasty-flaky.cabal @@ -0,0 +1,58 @@ +cabal-version: 3.4 +name: tasty-flaky +version: 0.1.0.0 +synopsis: Handle flaky Tasty-based tests +description: Handle flaky Tasty-based tests, with configuration retry policies. +homepage: https://github.com/PowerweaveInc/tasty-flaky +license: BSD-3-Clause +license-file: LICENSE +author: Laurent René de Cotret +maintainer: laurent@powerweave.io +copyright: (c) Powerweave Inc. +category: Testing +build-type: Simple +tested-with: GHC ==9.10.1 + || ==9.8.2 + || ==9.6.6 + || ==9.4.8 + || ==9.2.8 + || ==9.0.2 + || ==8.10.7 +extra-doc-files: CHANGELOG.md + README.md + + +source-repository head + type: git + location: https://github.com/PowerweaveInc/tasty-flaky.git + + +common common-options + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + default-language: Haskell2010 + +library + import: common-options + exposed-modules: Test.Tasty.Flaky + build-depends: base >=4.14 && <4.21 + , tagged >= 0.5 && <0.9 + , retry >= 0.7 && <0.10 + , tasty ^>=1.5 + hs-source-dirs: src + +test-suite tasty-flaky-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base + , tasty + , tasty-flaky + , tasty-hunit diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE NumericUnderscores #-} +module Main (main) where + +import Control.Monad ( unless ) +import Control.Concurrent ( threadDelay ) +import Data.IORef as IORef + +import Test.Tasty ( TestTree, testGroup, defaultMain, withResource ) +import Test.Tasty.Flaky ( limitRetries, flakyTest ) +import Test.Tasty.HUnit ( testCase, assertFailure ) + + +main :: IO () +main = defaultMain + $ testGroup "Test suite" + [ testSuccessOnFirstTry + , testFlakyWithRetries + , testFlakyWithRetriesProgressCallback + ] + + +testSuccessOnFirstTry :: TestTree +testSuccessOnFirstTry = flakyTest (limitRetries 0) $ testCase "succeeds on the first try" $ do + pure () + + +-- This test will fail until the contents of the IORef is zero +testFlakyWithRetries :: TestTree +testFlakyWithRetries + = flakyTest (limitRetries 4) + $ withResource (IORef.newIORef (3 :: Int)) (const $ pure ()) + $ \getioref -> testCase "effectful" $ do + ioref <- getioref + n <- IORef.readIORef ioref + unless (n == 0) $ do + IORef.modifyIORef' ioref (\m -> m - 1) + assertFailure "Not yet" + + +-- This test will fail until the contents of the IORef is zero +testFlakyWithRetriesProgressCallback :: TestTree +testFlakyWithRetriesProgressCallback + = flakyTest (limitRetries 4) + $ withResource (IORef.newIORef (3 :: Int)) (const $ pure ()) + $ \getioref -> testCase "Showcasing progress report" $ do + -- Wait 1 second for tasty to consider this test 'long-running' + threadDelay 1_000_000 + ioref <- getioref + n <- IORef.readIORef ioref + unless (n == 0) $ do + IORef.modifyIORef' ioref (\m -> m - 1) + assertFailure "Not yet" + +