From d99812b149aa0aaa773855fe2120a6d599b2f1db 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 +-- .../update-index-state.test.hs | 8 +-- cabal-testsuite/main/cabal-tests.hs | 16 ++++- cabal-testsuite/src/Test/Cabal/Monad.hs | 72 +++++++++++++++---- cabal-testsuite/src/Test/Cabal/Prelude.hs | 20 +++++- cabal-testsuite/src/Test/Cabal/TestCode.hs | 27 +++++-- 6 files changed, 113 insertions(+), 38 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..802a52689e6 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) @@ -321,7 +323,7 @@ main = do modifyMVar_ unexpected_fails_var $ \paths -> return (path:paths) - when (code == TestCodeUnexpectedOk) $ + when (isJust $ isTestCodeUnexpectedSuccess code) $ modifyMVar_ unexpected_passes_var $ \paths -> return (path:paths) @@ -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..a09be6d35aa 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 @@ -198,16 +200,25 @@ skipUnlessIO reason b = unless b (skipIO reason) skipUnless :: String -> Bool -> TestM () skipUnless reason b = unless b (skip reason) -expectedBroken :: Int -> TestM a -expectedBroken t = liftIO $ do +expectedBroken :: Int -> IO a +expectedBroken t = do putStrLn "EXPECTED FAIL" E.throwIO (TestCodeKnownFail t) -unexpectedSuccess :: TestM a -unexpectedSuccess = liftIO $ do +unexpectedSuccess :: Int -> IO a +unexpectedSuccess t = do putStrLn "UNEXPECTED OK" - E.throwIO TestCodeUnexpectedOk + E.throwIO (TestCodeUnexpectedOk t) +flakyFail :: Int -> IO a +flakyFail t = do + putStrLn "FLAKY FAIL" + E.throwIO (TestCodeFlakyFailed t) + +flakyPass :: Int -> IO a +flakyPass t = do + putStrLn "FLAKY OK" + E.throwIO (TestCodeFlakyPassed t) trySkip :: IO a -> IO (Either String a) trySkip m = fmap Right m `E.catch` \e -> case e of @@ -258,7 +269,7 @@ python3Program :: Program python3Program = simpleProgram "python3" -- | Run a test in the test monad according to program's arguments. -runTestM :: String -> TestM a -> IO a +runTestM :: String -> TestM () -> IO () runTestM mode m = liftIO $ (canonicalizePath =<< getTemporaryDirectory) >>= \systemTmpDir -> -- canonicalizePath: cabal-install is inconsistent w.r.t. looking through @@ -368,11 +379,26 @@ runTestM mode m = testRecordUserMode = Nothing, testMaybeStoreDir = Nothing } - let go = do cleanup - r <- withSourceCopy m - check_expect (argAccept (testCommonArgs args)) - return r - runReaderT go env + runReaderT cleanup env + join $ E.catch (runReaderT + (do + withSourceCopy m + check_expect (argAccept (testCommonArgs args)) Nothing + ) + env + ) + (\(e :: TestCode) -> do + -- A test that resulted in unexpected success should check its output + -- because maybe it is the output the one that makes it fail! + case isTestCodeUnexpectedSuccess e of + Just t -> runReaderT (check_expect (argAccept (testCommonArgs args)) (Just (t, False))) env + Nothing -> + -- A test that is reported flaky but passed might fail because of the output + case isTestCodeFlaky e of + Just (True, t) -> runReaderT (check_expect (argAccept (testCommonArgs args)) (Just (t, True))) env + _ -> E.throwIO e + ) + where verbosity = normal -- TODO: configurable @@ -388,13 +414,15 @@ runTestM mode m = liftIO $ writeFile (testUserCabalConfigFile env) $ unlines [ "with-compiler: " ++ ghc_path ] - check_expect accept = do + check_expect accept was_expected_to_fail = do env <- getTestEnv actual_raw <- liftIO $ readFileOrEmpty (testActualFile env) expect <- liftIO $ readFileOrEmpty (testExpectFile env) norm_env <- mkNormalizerEnv let actual = normalizeOutput norm_env actual_raw - when (words actual /= words expect) $ do + case (was_expected_to_fail, words actual /= words expect) of + -- normal test, output doesn't match + (Nothing, True) -> do -- First try whitespace insensitive diff let actual_fp = testNormalizedActualFile env expect_fp = testNormalizedExpectFile env @@ -406,7 +434,23 @@ runTestM mode m = if accept then do liftIO $ putStrLn "Accepting new output." liftIO $ writeFileNoCR (testExpectFile env) actual - else liftIO $ exitWith (ExitFailure 1) + pure (pure ()) + else pure (E.throwIO TestCodeFail) + -- normal test, output matches + (Nothing, False) -> pure (pure ()) + -- expected fail, output matches + (Just (t, was_flaky), False) -> pure (E.throwIO $ if was_flaky then TestCodeFlakyPassed t else TestCodeUnexpectedOk t) + -- expected fail, output doesn't match + (Just (t, was_flaky), True) -> do + -- First try whitespace insensitive diff + let actual_fp = testNormalizedActualFile env + expect_fp = testNormalizedExpectFile env + liftIO $ writeFile actual_fp actual + liftIO $ writeFile expect_fp expect + liftIO $ putStrLn "Actual output differs from expected:" + b <- diff ["-uw"] expect_fp actual_fp + unless b . void $ diff ["-u"] expect_fp actual_fp + pure (E.throwIO $ if was_flaky then TestCodeFlakyFailed t else TestCodeKnownFail t) readFileOrEmpty :: FilePath -> IO String readFileOrEmpty f = readFile f `E.catch` \e -> diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index 80653c49f3a..88c115453dd 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs @@ -973,9 +973,9 @@ expectBroken ticket m = do Left e -> do putStrLn $ "This test is known broken, see #" ++ show ticket ++ ":" print e - runReaderT (expectedBroken ticket) env + expectedBroken ticket Right _ -> do - runReaderT unexpectedSuccess env + unexpectedSuccess ticket expectBrokenIf :: Bool -> Int -> TestM a -> TestM a expectBrokenIf False _ m = m @@ -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 ticket + Right _ -> do + putStrLn $ "This test is known flaky, but it passed, see #" ++ show ticket ++ ":" + flakyPass ticket + -- * 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..3956eb31168 100644 --- a/cabal-testsuite/src/Test/Cabal/TestCode.hs +++ b/cabal-testsuite/src/Test/Cabal/TestCode.hs @@ -7,6 +7,8 @@ module Test.Cabal.TestCode ( TestCode (..), displayTestCode, isTestCodeSkip, + isTestCodeFlaky, + isTestCodeUnexpectedSuccess, ) where import Control.Exception (Exception (..)) @@ -20,8 +22,10 @@ data TestCode = TestCodeOk | TestCodeSkip String | TestCodeKnownFail Int - | TestCodeUnexpectedOk + | TestCodeUnexpectedOk Int | TestCodeFail + | TestCodeFlakyFailed Int + | TestCodeFlakyPassed Int deriving (Eq, Show, Read, Typeable) instance Exception TestCode @@ -31,12 +35,23 @@ instance Exception TestCode #endif displayTestCode :: TestCode -> String -displayTestCode TestCodeOk = "OK" -displayTestCode (TestCodeSkip msg) = "SKIP " ++ msg -displayTestCode (TestCodeKnownFail t) = "OK (known failure, see #" <> show t <> ")" -displayTestCode TestCodeUnexpectedOk = "FAIL (unexpected success)" -displayTestCode TestCodeFail = "FAIL" +displayTestCode TestCodeOk = "OK" +displayTestCode (TestCodeSkip msg) = "SKIP " ++ msg +displayTestCode (TestCodeKnownFail t) = "OK (known failure, see #" <> show t <> ")" +displayTestCode (TestCodeUnexpectedOk t) = "FAIL (unexpected success, see #" <> show t <> ")" +displayTestCode TestCodeFail = "FAIL" +displayTestCode (TestCodeFlakyFailed t) = "FLAKY (FAIL, see #" <> show t <> ")" +displayTestCode (TestCodeFlakyPassed t) = "FLAKY (OK, see #" <> show t <> ")" isTestCodeSkip :: TestCode -> Bool isTestCodeSkip (TestCodeSkip _) = True isTestCodeSkip _ = False + +isTestCodeFlaky :: TestCode -> Maybe (Bool, Int) +isTestCodeFlaky (TestCodeFlakyPassed t) = Just (True, t) +isTestCodeFlaky (TestCodeFlakyFailed t) = Just (False, t) +isTestCodeFlaky _ = Nothing + +isTestCodeUnexpectedSuccess :: TestCode -> Maybe Int +isTestCodeUnexpectedSuccess (TestCodeUnexpectedOk t) = Just t +isTestCodeUnexpectedSuccess _ = Nothing