From 78c3ab3573254abc7d7bf487f74a86027e8045e6 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 23 Jul 2024 23:41:38 +0200 Subject: [PATCH] Implement flaky combinator This can be used to specify flaky tests with a ticket number. These will be reported as passing or failing but will not make the test-suite error. --- .../RejectFutureIndexStates/cabal.test.hs | 8 +------- .../UpdateIndexState/update-index-state.test.hs | 8 +------- cabal-testsuite/main/cabal-tests.hs | 14 +++++++++++++- cabal-testsuite/src/Test/Cabal/Monad.hs | 11 +++++++++++ cabal-testsuite/src/Test/Cabal/Prelude.hs | 16 ++++++++++++++++ cabal-testsuite/src/Test/Cabal/TestCode.hs | 7 +++++++ 6 files changed, 49 insertions(+), 15 deletions(-) diff --git a/cabal-testsuite/PackageTests/NewUpdate/RejectFutureIndexStates/cabal.test.hs b/cabal-testsuite/PackageTests/NewUpdate/RejectFutureIndexStates/cabal.test.hs index 475a093360d..81ca4b88569 100644 --- a/cabal-testsuite/PackageTests/NewUpdate/RejectFutureIndexStates/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewUpdate/RejectFutureIndexStates/cabal.test.hs @@ -1,13 +1,7 @@ import Test.Cabal.Prelude import Data.List (isPrefixOf) -main = cabalTest $ do - - skip "Flaky test failing in `curl`, see #9530" - - testBody - -testBody = withProjectFile "cabal.project" $ withRemoteRepo "repo" $ do +main = cabalTest $ flaky 9530 $ withProjectFile "cabal.project" $ withRemoteRepo "repo" $ do output <- last . words diff --git a/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.test.hs b/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.test.hs index e6485d51f71..a212b0086c8 100644 --- a/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.test.hs +++ b/cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.test.hs @@ -1,12 +1,6 @@ import Test.Cabal.Prelude -main = cabalTest $ do - - skip "Flaky test failing in `curl`, see #9530" - - testBody - -testBody = withRemoteRepo "repo" $ do +main = cabalTest $ flaky 9530 $ withRemoteRepo "repo" $ do -- The _first_ update call causes a warning about missing mirrors, the warning -- is platform-dependent and it's not part of the test expectations, so we diff --git a/cabal-testsuite/main/cabal-tests.hs b/cabal-testsuite/main/cabal-tests.hs index f27ea9b6094..801e0c6a0fa 100644 --- a/cabal-testsuite/main/cabal-tests.hs +++ b/cabal-testsuite/main/cabal-tests.hs @@ -269,6 +269,8 @@ main = do unexpected_fails_var <- newMVar [] unexpected_passes_var <- newMVar [] skipped_var <- newMVar [] + flaky_pass_var <- newMVar [] + flaky_fail_var <- newMVar [] chan <- newChan let logAll msg = writeChan chan (ServerLogMsg AllServers msg) @@ -329,6 +331,12 @@ main = do modifyMVar_ skipped_var $ \paths -> return (path:paths) + case isTestCodeFlaky code of + Nothing -> pure () + Just b -> + modifyMVar_ (if b then flaky_pass_var else flaky_fail_var) $ \paths -> + return (path:paths) + go server -- Start as many threads as requested by -j to spawn @@ -339,13 +347,17 @@ main = do unexpected_fails <- takeMVar unexpected_fails_var unexpected_passes <- takeMVar unexpected_passes_var skipped <- takeMVar skipped_var + flaky_passes <- takeMVar flaky_pass_var + flaky_fails <- takeMVar flaky_fail_var -- print summary let sl = show . length testSummary = sl all_tests ++ " tests, " ++ sl skipped ++ " skipped, " ++ sl unexpected_passes ++ " unexpected passes, " - ++ sl unexpected_fails ++ " unexpected fails." + ++ sl unexpected_fails ++ " unexpected fails, " + ++ sl flaky_passes ++ " flaky passes, " + ++ sl flaky_fails ++ " flaky fails." logAll testSummary -- print failed or unexpected ok diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs index 04eb659696c..64cd38ee87e 100644 --- a/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/cabal-testsuite/src/Test/Cabal/Monad.hs @@ -59,6 +59,8 @@ module Test.Cabal.Monad ( commonArgParser, -- * Version Constants cabalVersionLibrary, + flakyFail, + flakyPass, ) where import Test.Cabal.Script @@ -208,6 +210,15 @@ unexpectedSuccess = liftIO $ do putStrLn "UNEXPECTED OK" E.throwIO TestCodeUnexpectedOk +flakyFail :: IO a +flakyFail = do + putStrLn "FLAKY FAIL" + E.throwIO (TestCodeFlaky False) + +flakyPass :: IO a +flakyPass = do + putStrLn "FLAKY OK" + E.throwIO (TestCodeFlaky True) trySkip :: IO a -> IO (Either String a) trySkip m = fmap Right m `E.catch` \e -> case e of diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index 80653c49f3a..0623f880c85 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs @@ -984,6 +984,22 @@ expectBrokenIf True ticket m = expectBroken ticket m expectBrokenUnless :: Bool -> Int -> TestM a -> TestM a expectBrokenUnless b = expectBrokenIf (not b) +-- * Flaky tests + +flaky :: Int -> TestM a -> TestM a +flaky ticket m = do + env <- getTestEnv + liftIO . withAsync (runReaderT m env) $ \a -> do + r <- waitCatch a + case r of + Left e -> do + putStrLn $ "This test is known flaky, and it failed, see #" ++ show ticket ++ ":" + print e + flakyFail + Right _ -> do + putStrLn $ "This test is known flaky, but it passed, see #" ++ show ticket ++ ":" + flakyPass + -- * Programs git :: String -> [String] -> TestM () diff --git a/cabal-testsuite/src/Test/Cabal/TestCode.hs b/cabal-testsuite/src/Test/Cabal/TestCode.hs index 4d0762bdae5..471f5c68917 100644 --- a/cabal-testsuite/src/Test/Cabal/TestCode.hs +++ b/cabal-testsuite/src/Test/Cabal/TestCode.hs @@ -7,6 +7,7 @@ module Test.Cabal.TestCode ( TestCode (..), displayTestCode, isTestCodeSkip, + isTestCodeFlaky, ) where import Control.Exception (Exception (..)) @@ -22,6 +23,7 @@ data TestCode | TestCodeKnownFail Int | TestCodeUnexpectedOk | TestCodeFail + | TestCodeFlaky Bool deriving (Eq, Show, Read, Typeable) instance Exception TestCode @@ -36,7 +38,12 @@ displayTestCode (TestCodeSkip msg) = "SKIP " ++ msg displayTestCode (TestCodeKnownFail t) = "OK (known failure, see #" <> show t <> ")" displayTestCode TestCodeUnexpectedOk = "FAIL (unexpected success)" displayTestCode TestCodeFail = "FAIL" +displayTestCode (TestCodeFlaky b) = "FLAKY " ++ if b then "OK" else "FAIL" isTestCodeSkip :: TestCode -> Bool isTestCodeSkip (TestCodeSkip _) = True isTestCodeSkip _ = False + +isTestCodeFlaky :: TestCode -> Maybe Bool +isTestCodeFlaky (TestCodeFlaky b) = Just b +isTestCodeFlaky _ = Nothing