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

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

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

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