From 654daa56452e10f412383718fd1121881230d4e5 Mon Sep 17 00:00:00 2001 From: jschaul Date: Thu, 23 Jul 2026 10:28:04 +0200 Subject: [PATCH 1/4] deflake attempt --- integration/test/Testlib/ModService.hs | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 0c4f7d0cc35..5dc2ad08194 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -34,7 +34,7 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as E -import Control.Monad.Catch (catch, throwM) +import Control.Monad.Catch (catch, catchAll, throwM) import Control.Monad.Codensity import Control.Monad.Extra import Control.Monad.Reader @@ -459,14 +459,22 @@ checkFederationIngress origin target = do . (addJSONObject []) checkStatus <- appToIO $ do submit "POST" req `bindResponse` \res -> do - let is200 = res.status == 200 - mInner <- lookupField res.json "inner" - isFedDenied <- case mInner of - Nothing -> pure False - Just inner -> do - label <- inner %. "label" & asString - pure $ res.status == 533 && label == "federation-denied" - pure (is200 || isFedDenied) + case res.json of + -- A federator can briefly return an empty or JSON-null body while the + -- backend is warming up. Keep the retry alive instead of letting + -- lookupField turn that transient response into a test failure. + Just (Object _) -> do + let is200 = res.status == 200 + mInner <- lookupField res.json "inner" + isFedDenied <- case mInner of + Nothing -> pure False + Just inner -> + (do + label <- inner %. "label" & asString + pure $ res.status == 533 && label == "federation-denied" + ) `catchAll` const (pure False) + pure (is200 || isFedDenied) + _ -> pure False eith <- liftIO (E.try checkStatus) pure $ either (\(_e :: HTTP.HttpException) -> False) id eith From 5f7d9d9fad4b1152ddd347238605c01977bf46ec Mon Sep 17 00:00:00 2001 From: jschaul Date: Thu, 23 Jul 2026 10:53:10 +0200 Subject: [PATCH 2/4] Attempt to deflake: warm federation paths more --- integration/test/Testlib/ModService.hs | 37 ++++++++++++++++++-------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 5dc2ad08194..d04d112bbf5 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -63,6 +63,7 @@ import qualified Data.Yaml as Yaml import GHC.Stack import qualified Network.HTTP.Client as HTTP import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeDirectoryRecursive, removeFile) +import System.Environment (lookupEnv) import System.Exit import System.FilePath import System.IO @@ -669,23 +670,37 @@ logToConsoleDebug mOutput colorize prefix hdl = do federatorIngressDelay :: Int federatorIngressDelay = 30 * 1000 * 1000 --- | Pre-warm the static 'domain1' <-> 'domain2' federation path once, before --- the test suite bursts. 'ensureBackendReachable' only warms /dynamic/ backends --- (it skips the two static domains), so the very first cross-domain call --- between them can fail with a transient federator-transport error --- (521 connection refused, 525 SSL, 533 unreachable backend). Polling the --- federator ingress in both directions here removes that cold-start race --- globally, rather than retrying individual requests whose execution order is --- not guaranteed. +-- | Pre-warm the static federation paths once, before the test suite bursts. +-- 'ensureBackendReachable' only warms dynamic backends, so static federation +-- paths must be warmed here before tests run concurrently. warmupFederation :: (HasCallStack) => App () warmupFederation = do env <- ask - let checkBoth = + enabledFedDomains <- liftIO $ fmap catMaybes $ for + [ (env.federationV0Domain, "ENABLE_FEDERATION_V0"), + (env.federationV1Domain, "ENABLE_FEDERATION_V1"), + (env.federationV2Domain, "ENABLE_FEDERATION_V2") + ] + $ \(domain, flag) -> do + enabled <- lookupEnv flag + pure $ if enabled == Just "1" then Just domain else Nothing + let primaryDomains = [env.domain1, env.domain2] + federationPairs = + [(env.domain1, env.domain2), (env.domain2, env.domain1)] + <> [ (origin, fedDomain) + | fedDomain <- enabledFedDomains, + origin <- primaryDomains + ] + <> [ (fedDomain, origin) + | fedDomain <- enabledFedDomains, + origin <- primaryDomains + ] + checkAll = and <$> traverse (uncurry checkFederationIngress) - [(env.domain1, env.domain2), (env.domain2, env.domain1)] - retryRequestUntil checkBoth "Static federator ingress (domain1 <-> domain2)" + federationPairs + retryRequestUntil checkAll "Static federator ingress" retryRequestUntil :: (HasCallStack) => ((HasCallStack) => App Bool) -> String -> App () retryRequestUntil = retryRequestUntilDebug federatorIngressDelay Nothing From a3d6326a37663dbc401e8c10f11cc02e95b04c69 Mon Sep 17 00:00:00 2001 From: jschaul Date: Thu, 23 Jul 2026 11:14:06 +0200 Subject: [PATCH 3/4] ... --- integration/test/Testlib/ModService.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index d04d112bbf5..182a6fa3ef0 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -34,7 +34,7 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as E -import Control.Monad.Catch (catch, catchAll, throwM) +import Control.Monad.Catch (catch, throwM) import Control.Monad.Codensity import Control.Monad.Extra import Control.Monad.Reader @@ -473,7 +473,7 @@ checkFederationIngress origin target = do (do label <- inner %. "label" & asString pure $ res.status == 533 && label == "federation-denied" - ) `catchAll` const (pure False) + ) `catch` \(_ :: AssertionFailure) -> pure False pure (is200 || isFedDenied) _ -> pure False eith <- liftIO (E.try checkStatus) From e1f39ce763d6814a19432fb88513d059ec63d133 Mon Sep 17 00:00:00 2001 From: jschaul Date: Thu, 23 Jul 2026 11:16:58 +0200 Subject: [PATCH 4/4] linting --- integration/test/Testlib/ModService.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 182a6fa3ef0..a92672c0def 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -470,10 +470,11 @@ checkFederationIngress origin target = do isFedDenied <- case mInner of Nothing -> pure False Just inner -> - (do + ( do label <- inner %. "label" & asString pure $ res.status == 533 && label == "federation-denied" - ) `catch` \(_ :: AssertionFailure) -> pure False + ) + `catch` \(_ :: AssertionFailure) -> pure False pure (is200 || isFedDenied) _ -> pure False eith <- liftIO (E.try checkStatus) @@ -676,11 +677,13 @@ federatorIngressDelay = 30 * 1000 * 1000 warmupFederation :: (HasCallStack) => App () warmupFederation = do env <- ask - enabledFedDomains <- liftIO $ fmap catMaybes $ for - [ (env.federationV0Domain, "ENABLE_FEDERATION_V0"), - (env.federationV1Domain, "ENABLE_FEDERATION_V1"), - (env.federationV2Domain, "ENABLE_FEDERATION_V2") - ] + enabledFedDomains <- liftIO + $ fmap catMaybes + $ for + [ (env.federationV0Domain, "ENABLE_FEDERATION_V0"), + (env.federationV1Domain, "ENABLE_FEDERATION_V1"), + (env.federationV2Domain, "ENABLE_FEDERATION_V2") + ] $ \(domain, flag) -> do enabled <- lookupEnv flag pure $ if enabled == Just "1" then Just domain else Nothing