diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 0c4f7d0cc35..a92672c0def 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 @@ -459,14 +460,23 @@ 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" + ) + `catch` \(_ :: AssertionFailure) -> pure False + pure (is200 || isFedDenied) + _ -> pure False eith <- liftIO (E.try checkStatus) pure $ either (\(_e :: HTTP.HttpException) -> False) id eith @@ -661,23 +671,39 @@ 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