Skip to content

Commit

Permalink
Simplify itWithCustomTimeout implementation
Browse files Browse the repository at this point in the history
with Matthias suggestion.
  • Loading branch information
Anviking committed Oct 1, 2020
1 parent 766200b commit 01a21e7
Show file tree
Hide file tree
Showing 2 changed files with 25 additions and 34 deletions.
53 changes: 22 additions & 31 deletions lib/test-utils/src/Test/Hspec/Extra.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,13 +22,11 @@ import Prelude
import Control.Concurrent
( threadDelay )
import Control.Concurrent.Async
( AsyncCancelled, async, race, race_, wait )
( AsyncCancelled, async, race, wait )
import Control.Concurrent.MVar
( MVar, newEmptyMVar, putMVar, takeMVar )
import Control.Exception
( SomeException, fromException, throwIO, try )
import Data.Maybe
( isJust )
( SomeException, catch, throwIO )
import Test.Hspec
( ActionWith
, HasCallStack
Expand Down Expand Up @@ -115,36 +113,29 @@ aroundAll acquire =
it :: HasCallStack => String -> ActionWith ctx -> SpecWith ctx
it = itWithCustomTimeout (10*minute)
where
minute = 60*1000*1000
minute = 60

-- | 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
itWithCustomTimeout
:: HasCallStack
=> Int -- ^ Timeout in seconds.
-> String
-> ActionWith ctx
-> SpecWith ctx
itWithCustomTimeout sec title action = specify title $ \ctx -> timeout sec $ do
action ctx
`catch` (\(_ :: AsyncCancelled) -> return ())
`catch` (\(e :: SomeException) -> action ctx
`catch` (\(_ :: SomeException) -> throwIO e))
where
isAsyncCancelled = isJust . fromException @AsyncCancelled
timeout = do
threadDelay micro
expectationFailure
$ "timed out in "
<> show (micro `div` 1000000)
<> " seconds"
timeout t act =
race (threadDelay (micro t)) act >>= \case
Right () ->
return ()
Left () ->
expectationFailure $ "timed out in " <> show t <> " seconds"
where
micro = (* 1000) . (* 1000)

-- | Some helper to help readability on the thread synchronization above.
await :: MVar () -> IO ()
Expand Down
6 changes: 3 additions & 3 deletions lib/test-utils/test/Test/Hspec/ExtraSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -56,11 +56,11 @@ spec = do
outcomes <- newIORef [failure, noRetry]
(dynamically outcomes) `shouldMatchHSpecIt` failure
it "can time out" $ do
let s = 1000*1000
let micro = (1000*1000 *)
let timeout = do
threadDelay (10 * s)
threadDelay (micro 10)
expectationFailure "should have timed out"
res <- run (Extra.itWithCustomTimeout $ 2 * s) timeout
res <- run (Extra.itWithCustomTimeout 2) timeout
res `shouldContain` "timed out in 2 seconds"

where
Expand Down

0 comments on commit 01a21e7

Please sign in to comment.