Add a 10 min timeout to it

Instead of causing the CI to timeout, we should now get the test causing
the timeout to fail.

Author: Anviking

lib/test-utils/src/Test/Hspec/Extra.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- |
 -- Copyright: © 2018-2020 IOHK
@@ -13,16 +14,23 @@
 module Test.Hspec.Extra
     ( aroundAll
     , it
+    , itWithCustomTimeout
     ) where
 
 import Prelude
 
+import Control.Concurrent
+    ( threadDelay )
 import Control.Concurrent.Async
-    ( async, race, wait )
+    ( AsyncCancelled, async, race, race_, wait )
 import Control.Concurrent.MVar
     ( MVar, newEmptyMVar, putMVar, takeMVar )
+import Control.Exception
+    ( fromException )
 import Control.Exception
     ( SomeException, throwIO, try )
+import Data.Maybe
+    ( isJust )
 import Test.Hspec
     ( ActionWith
     , HasCallStack
@@ -31,6 +39,7 @@ import Test.Hspec
     , afterAll
     , beforeAll
     , beforeWith
+    , expectationFailure
     , specify
     )
 
@@ -104,17 +113,39 @@ aroundAll acquire =
 -- | A drop-in replacement for 'it' that'll automatically retry a scenario once
 -- if it fails, to cope with potentially flaky tests.
 it :: HasCallStack => String -> ActionWith ctx -> SpecWith ctx
-it title action = specify title $ \ctx -> do
-   res1 <- try $ action ctx
-   case res1 of
-       Right r1 -> return r1
-       Left (e1 :: SomeException) -> do
-           res2 <- try $ action ctx
-           case res2 of
-               -- If the second try fails, return the first error. The
-               -- second error might not be helpful.
-               Left (_e2 :: SomeException) -> throwIO e1
-               Right r2 -> return r2
+it = itWithCustomTimeout (10*minute)
+  where
+    minute = 60*1000*1000
+
+-- | Like @it@ but with a custom timeout, which makes it realistic to test.
+itWithCustomTimeout :: HasCallStack => Int -> String -> ActionWith ctx -> SpecWith ctx
+itWithCustomTimeout micro title action = specify title $ \ctx -> do
+    race_ timeout $ do
+        res1 <- try $ action ctx
+        case res1 of
+            Right r1 -> return r1
+            Left (e1 :: SomeException)
+                -- If we time out during the first attempt, then we /should/ time
+                -- out.
+                | isAsyncCancelled e1 -> throwIO e1
+                | otherwise           -> do
+                res2 <- try $ action ctx
+                case res2 of
+                    -- If the second try fails, return the first error. The
+                    -- second error might not be helpful.
+                    Left (e2 :: SomeException)
+                        | isAsyncCancelled e2 -> throwIO e1
+                        | otherwise           -> throwIO e1
+                    Right r2 -> return r2
+  where
+    isAsyncCancelled = isJust . fromException @AsyncCancelled
+    timeout = do
+        threadDelay micro
+        putStrLn "-------- timing out "
+        expectationFailure
+            $ "timed out in "
+            <> show (micro `div` 1000000)
+            <> " seconds"
 
 -- | Some helper to help readability on the thread synchronization above.
 await :: MVar () -> IO ()

lib/test-utils/test/Test/Hspec/ExtraSpec.hs

@@ -2,6 +2,8 @@ module Test.Hspec.ExtraSpec where
 
 import Prelude
 
+import Control.Concurrent
+    ( threadDelay )
 import Data.IORef
     ( IORef, newIORef, readIORef, writeIORef )
 import Data.List
@@ -18,6 +20,7 @@ import Test.Hspec
     , expectationFailure
     , it
     , shouldBe
+    , shouldContain
     )
 import Test.Hspec.Core.Runner
     ( defaultConfig, runSpec )
@@ -52,6 +55,14 @@ spec = do
                     let noRetry = expectationFailure "test can't be retried"
                     outcomes <- newIORef [failure, noRetry]
                     (dynamically outcomes) `shouldMatchHSpecIt` failure
+        it "can time out" $ do
+            let s = 1000*1000
+            let timeout = do
+                    threadDelay (10 * s)
+                    expectationFailure "should have timed out"
+            res <- run (Extra.itWithCustomTimeout $ 2 * s) timeout
+            res `shouldContain` "timed out in 2 seconds"
+
   where
     -- | lhs `shouldMatchHSpecIt` rhs asserts that the output of running
     -- (Extra.it "" lhs) and (Hspec.it "" rhs) are equal. Modulo random seed-
@@ -62,17 +73,16 @@ spec = do
         hspecRes <- run it hspecTest
         extraRes `shouldBe` hspecRes
 
+    run
+        :: (String -> ActionWith () -> SpecWith ())
+        -> IO ()
+        -> IO String
+    run anyIt prop = fmap stripTime
+        $ capture_
+        $ flip runSpec defaultConfig
+        $ beforeAll (return ())
+        $ anyIt "<test spec>" (const prop)
       where
-        run
-            :: (String -> ActionWith () -> SpecWith ())
-            -> IO ()
-            -> IO String
-        run anyIt prop = fmap stripTime
-            $ capture_
-            $ flip runSpec defaultConfig
-            $ beforeAll (return ())
-            $ anyIt "<test spec>" (const prop)
-
         stripTime :: String -> String
         stripTime = unlines
                 . filter (not . ("Finished in" `isPrefixOf`))