Merge remote-tracking branch 'origin/adinapoli/issue-408' into dev

test/Test/Utils/Jobs.hs

@@ -363,23 +363,30 @@ testMarkProgress = do
   myEnv <- newTestEnv
   -- evts  <- newTBQueueIO 7
   evts <- newTVarIO []
+  let expectedEvents = 7
   let getStatus hdl = do
         liftIO $ threadDelay 100_000
         st <- getLatestJobStatus hdl
         -- liftIO $ atomically $ writeTBQueue evts st
         liftIO $ atomically $ modifyTVar evts (\xs -> xs ++ [st])
-      readAllEvents = do  
+      readAllEvents = do
         -- We will get thread blocking if there is ANY error in the job
         -- Hence we assert the `readAllEvents` test doesn't take too long
-        mRet <- timeout 1_000_000 $ atomically $ do
+        mRet <- timeout 5_000_000 $ atomically $ do
           -- allEventsArrived <- isFullTBQueue evts
           evts' <- readTVar evts
           -- STM retry if things failed
           -- check allEventsArrived
-          check (length evts' == 7)
+          check (length evts' == expectedEvents)
           -- flushTBQueue evts
-          return evts'
-        return $ fromMaybe [] mRet
+          pure evts'
+        case mRet of
+          Nothing -> Prelude.fail $ "testMarkProgress: timeout exceeded, but didn't receive all 7 required events."
+          Just xs
+            | length xs == expectedEvents
+            -> pure xs
+            | otherwise
+            -> Prelude.fail $ "testMarkProgress: received some events, but they were not of the expected number (" <> show expectedEvents <> "): " <> show xs
 
   withJob_ myEnv $ \hdl _input -> do
     markStarted 10 hdl
@@ -406,6 +413,8 @@ testMarkProgress = do
     getStatus hdl
 
   evts' <- readAllEvents
+  -- This pattern match should never fail, because the precondition is
+  -- checked in 'readAllEvents'.
   let [jl0, jl1, jl2, jl3, jl4, jl5, jl6] = evts'
 
   -- Check the events are what we expect