diff --git a/integration/test/Test/Demo.hs b/integration/test/Test/Demo.hs index f8a1bffa08..87202291f1 100644 --- a/integration/test/Test/Demo.hs +++ b/integration/test/Test/Demo.hs @@ -68,3 +68,13 @@ testMultipleBackends = do ownDomainRes `shouldMatch` ownDomain otherDomainRes `shouldMatch` otherDomain ownDomain `shouldNotMatch` otherDomain + +testUnrace :: App () +testUnrace = do + {- + -- the following would retry for ~30s and only then fail + unrace $ do + True `shouldMatch` True + True `shouldMatch` False + -} + unrace $ True `shouldMatch` True diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs index ab88325489..b37469345b 100644 --- a/integration/test/Testlib/App.hs +++ b/integration/test/Testlib/App.hs @@ -1,6 +1,7 @@ module Testlib.App where import Control.Monad.Reader +import qualified Control.Retry as Retry import Data.Aeson hiding ((.=)) import Data.IORef import qualified Data.Yaml as Yaml @@ -49,3 +50,12 @@ ownDomain = asks (.domain1) otherDomain :: App String otherDomain = asks (.domain2) + +-- | Run an action, `recoverAll`ing with exponential backoff (min step 8ms, total timeout +-- ~15s). Search this package for examples how to use it. +-- +-- Ideally, this will be the only thing you'll ever need from the retry package when writing +-- integration tests. If you are unhappy with it,, please consider fixing it so everybody can +-- benefit. +unrace :: App a -> App a +unrace action = Retry.recoverAll (Retry.exponentialBackoff 8000 <> Retry.limitRetries 10) (const action) diff --git a/integration/test/Testlib/Cannon.hs b/integration/test/Testlib/Cannon.hs index caebbdeb54..94df997820 100644 --- a/integration/test/Testlib/Cannon.hs +++ b/integration/test/Testlib/Cannon.hs @@ -161,22 +161,17 @@ run wsConnect app = do ) `onException` tryPutMVar latch () - let waitForRegistry :: HasCallStack => Int -> App () - waitForRegistry (0 :: Int) = failApp "Cannon: failed to register presence" - waitForRegistry n = do + let waitForRegistry :: HasCallStack => App () + waitForRegistry = unrace $ do request <- baseRequest ownDomain Cannon Unversioned ("/i/presences/" <> wsConnect.user <> "/" <> connId) response <- submit "HEAD" request - unless (status response == 200) $ do - liftIO $ threadDelay $ 100 * 1000 - waitForRegistry (n - 1) + status response `shouldMatchInt` 200 liftIO $ takeMVar latch stat <- liftIO $ poll wsapp case stat of Just (Left ex) -> liftIO $ throwIO ex - _ -> waitForRegistry numRetries >> pure wsapp - where - numRetries = 30 + _ -> waitForRegistry >> pure wsapp close :: MonadIO m => WebSocket -> m () close ws = liftIO $ do