From c4519f2854494488d58a6b7e941ed27a77ad8e17 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 9 May 2023 11:34:49 +0200 Subject: [PATCH 1/7] Add `unrace` idiom to integration tests. --- integration/test/Test/Demo.hs | 10 ++++++++++ integration/test/Testlib/App.hs | 10 ++++++++++ integration/test/Testlib/Cannon.hs | 13 ++++--------- 3 files changed, 24 insertions(+), 9 deletions(-) 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..0862ec63c0 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 +-- ~30s). 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 11) (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 From b986f382465d04aa990cd61b0546250d04362b14 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 9 May 2023 13:03:12 +0200 Subject: [PATCH 2/7] Test for new hlint rules. (Roll back before merging!) --- integration/test/Test/Demo.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/integration/test/Test/Demo.hs b/integration/test/Test/Demo.hs index 87202291f1..8e197a9135 100644 --- a/integration/test/Test/Demo.hs +++ b/integration/test/Test/Demo.hs @@ -3,6 +3,8 @@ module Test.Demo where import qualified API.Brig as Public import qualified API.GalleyInternal as Internal +import Control.Concurrent +import Control.Retry import GHC.Stack import SetupHelpers import Testlib.Prelude @@ -77,4 +79,5 @@ testUnrace = do True `shouldMatch` True True `shouldMatch` False -} + () <- undefined (recovering @IO) threadDelay unrace $ True `shouldMatch` True From 818741bc19928bc61e471b9328633b60122ca7c6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 9 May 2023 13:03:35 +0200 Subject: [PATCH 3/7] hlint rules (not working). --- .hlint.yaml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.hlint.yaml b/.hlint.yaml index 36c1e8c90f..8ffec2679d 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -12,11 +12,15 @@ - ignore: { name: Eta reduce } - ignore: { name: Use section } - ignore: { name: Use underscore } +- ignore: { name: no recovering } +- ignore: { name: no threadDelay } # custom rules: - hint: { lhs: (() <$), rhs: void } - hint: { lhs: return, rhs: pure } - hint: { lhs: maybe mempty, rhs: foldMap } +- hint: { name: no threadDelay, lhs: threadDelay, rhs: unrace } +- hint: { name: no recovering, lhs: recovering, rhs: unrace } # We want the latter function because it handles signals properly. - error: { name: Use shutdown, lhs: runSettings, rhs: runSettingsWithShutdown } From 1cdb55cfd4cc86aa4d1ac6e59745b870495b42c4 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 9 May 2023 14:48:38 +0200 Subject: [PATCH 4/7] Revert "Test for new hlint rules. (Roll back before merging!)" This reverts commit b986f382465d04aa990cd61b0546250d04362b14. --- integration/test/Test/Demo.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/integration/test/Test/Demo.hs b/integration/test/Test/Demo.hs index 8e197a9135..87202291f1 100644 --- a/integration/test/Test/Demo.hs +++ b/integration/test/Test/Demo.hs @@ -3,8 +3,6 @@ module Test.Demo where import qualified API.Brig as Public import qualified API.GalleyInternal as Internal -import Control.Concurrent -import Control.Retry import GHC.Stack import SetupHelpers import Testlib.Prelude @@ -79,5 +77,4 @@ testUnrace = do True `shouldMatch` True True `shouldMatch` False -} - () <- undefined (recovering @IO) threadDelay unrace $ True `shouldMatch` True From 6a507b26e62ed57f1262844334ebd71a259d04bf Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 9 May 2023 14:48:54 +0200 Subject: [PATCH 5/7] Revert "hlint rules (not working)." This reverts commit 818741bc19928bc61e471b9328633b60122ca7c6. --- .hlint.yaml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 8ffec2679d..36c1e8c90f 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -12,15 +12,11 @@ - ignore: { name: Eta reduce } - ignore: { name: Use section } - ignore: { name: Use underscore } -- ignore: { name: no recovering } -- ignore: { name: no threadDelay } # custom rules: - hint: { lhs: (() <$), rhs: void } - hint: { lhs: return, rhs: pure } - hint: { lhs: maybe mempty, rhs: foldMap } -- hint: { name: no threadDelay, lhs: threadDelay, rhs: unrace } -- hint: { name: no recovering, lhs: recovering, rhs: unrace } # We want the latter function because it handles signals properly. - error: { name: Use shutdown, lhs: runSettings, rhs: runSettingsWithShutdown } From 7767938e85eaa7d3612ed5257b69bbc1feb5acff Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 9 May 2023 15:38:57 +0200 Subject: [PATCH 6/7] hi ci From 8cc79970d03da2e78c6441e558f86f5fee38fc03 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 9 May 2023 16:31:05 +0200 Subject: [PATCH 7/7] Give up after ~15s. --- integration/test/Testlib/App.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs index 0862ec63c0..b37469345b 100644 --- a/integration/test/Testlib/App.hs +++ b/integration/test/Testlib/App.hs @@ -52,10 +52,10 @@ otherDomain :: App String otherDomain = asks (.domain2) -- | Run an action, `recoverAll`ing with exponential backoff (min step 8ms, total timeout --- ~30s). Search this package for examples how to use it. +-- ~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 11) (const action) +unrace action = Retry.recoverAll (Retry.exponentialBackoff 8000 <> Retry.limitRetries 10) (const action)