Handle race conditions in /integration

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

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)

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