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.

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

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

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,14 +323,20 @@ 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)
 
                             when (isTestCodeSkip code) $
                                 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

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 ->

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 ()

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