{-# LANGUAGE OverloadedStrings #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Testlib.ModService
  ( withModifiedBackend,
    startDynamicBackend,
    startDynamicBackends,
    startDynamicBackendsReturnResources,
    traverseConcurrentlyCodensity,
    defaultOverrides,
    readAndUpdateConfig,
    logToConsole,
    warmupFederation,
  )
where

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.Codensity
import Control.Monad.Extra
import Control.Monad.Reader
import Control.Retry (fibonacciBackoff, limitRetriesByCumulativeDelay, retrying)
import Data.Aeson hiding ((.=))
import qualified Data.Attoparsec.Text as Parser
import qualified Data.Char as Char
import Data.Default
import Data.Foldable
import Data.Function
import Data.Functor
import Data.IORef
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.String
import Data.String.Conversions (cs)
import Data.String.Interpolate
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Traversable
import Data.Word
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.Exit
import System.FilePath
import System.IO
import System.IO.Error (isDoesNotExistError)
import System.IO.Temp (createTempDirectory, writeTempFile)
import qualified System.Linux.Proc as LinuxProc
import System.Posix (keyboardSignal, killProcess, signalProcess)
import System.Posix.Types
import System.Process
import Testlib.App
import Testlib.HTTP
import Testlib.JSON
import Testlib.Ports (PortNamespace (..))
import Testlib.Printing
import Testlib.ResourcePool
import Testlib.Types
import Text.RE.Replace
import Text.RE.TDFA
import qualified UnliftIO
import Prelude

withModifiedBackend :: (HasCallStack) => ServiceOverrides -> ((HasCallStack) => String -> App a) -> App a
withModifiedBackend overrides k =
  startDynamicBackends [overrides] (\[domains] -> k domains)

copyDirectoryRecursively :: FilePath -> FilePath -> IO ()
copyDirectoryRecursively from to = do
  createDirectoryIfMissing True to
  files <- listDirectory from
  for_ files $ \file -> do
    let fromPath = from </> file
    let toPath = to </> file
    isDirectory <- doesDirectoryExist fromPath
    if isDirectory
      then copyDirectoryRecursively fromPath toPath
      else copyFile fromPath toPath

-- | Concurrent traverse in the 'Codensity App' monad.
traverseConcurrentlyCodensity ::
  ((HasCallStack) => a -> Codensity App ()) ->
  ((HasCallStack) => [a] -> Codensity App ())
traverseConcurrentlyCodensity f args = do
  -- Create variables for synchronisation of the various threads:
  --  * @result@ is used to store a possible exception
  --  * @done@ is used to signal that the main continuation has finished, so
  --    the thread can resume and move on to the cleanup phase.
  -- There is one pair of @(result, done)@ variables for each thread.
  vars <- liftIO $ for args $ \_ -> do
    result <- newEmptyMVar
    done <- newEmptyMVar
    pure (result, done)

  -- Create an IO Kleisli arrow that runs an action and synchronises using its
  -- two variables. This arrow will later be used to spawn a thread.
  runAction <- lift $ appToIOKleisli $ \((result, done), arg) ->
    catch
      ( runCodensity (f arg) $ \_ -> liftIO $ do
          putMVar result Nothing
          takeMVar done
      )
      $ \(e :: E.SomeException) ->
        void . liftIO $ tryPutMVar result (Just e)

  -- Spawn threads. Here we use the fact that 'withAsync' implicitly returns a
  -- 'Codensity' action, and use the 'Monad' instance of 'Codensity' to
  -- sequence these actions together. This is like nesting all the CPS
  -- invocations of 'withAsync' one inside the other, but without the need for
  -- explicit recursion.
  asyncs <- for (zip vars args) $ \x ->
    hoistCodensity $ Codensity $ withAsync (runAction x)

  -- Wait for all the threads set their result variables. Any exception is
  -- rethrown here, and aborts the overall function.
  liftIO $ for_ vars $ \(result, _) ->
    takeMVar result >>= maybe (pure ()) throwM

  Codensity $ \k -> do
    -- Now run the main continuation.
    result <- k ()

    -- Finally, signal all threads that it is time to clean up, and wait for
    -- them to finish. Note that this last block might not be executed in case
    -- of exceptions, but this is not a problem, because all the async threads
    -- are running within a 'withAsync' block, so they will be automatically
    -- cancelled in that case.
    liftIO $ traverse_ (\(_, d) -> putMVar d ()) vars
    liftIO $ traverse_ wait asyncs

    pure result

startDynamicBackends :: (HasCallStack) => [ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends beOverrides k = do
  startDynamicBackendsReturnResources beOverrides (\resources -> k $ map (.berDomain) resources)

startDynamicBackendsReturnResources :: (HasCallStack) => [ServiceOverrides] -> ([BackendResource] -> App a) -> App a
startDynamicBackendsReturnResources beOverrides k = do
  let startDynamicBackendsCodensity = do
        when (Prelude.length beOverrides > 3) $ lift $ failApp "Too many backends. Currently only 3 are supported."
        pool <- asks (.resourcePool)
        resources <- acquireResources (Prelude.length beOverrides) pool
        void $
          traverseConcurrentlyCodensity
            (void . uncurry startDynamicBackend)
            (zip resources beOverrides)
        pure resources
  runCodensity startDynamicBackendsCodensity k

startDynamicBackend :: (HasCallStack) => BackendResource -> ServiceOverrides -> Codensity App String
startDynamicBackend resource beOverrides = do
  startBackend resource $ defaultOverrides resource <> beOverrides
  pure resource.berDomain

defaultOverrides :: BackendResource -> ServiceOverrides
defaultOverrides resource =
  mconcat
    [ setKeyspace,
      setEsIndex,
      setPgDb,
      setFederationSettings,
      setAwsConfigs,
      setMlsPrivateKeyPaths,
      setLogLevel
    ]
  where
    setAwsConfigs :: ServiceOverrides
    setAwsConfigs =
      def
        { brigCfg =
            setField "aws.userJournalQueue" resource.berAwsUserJournalQueue
              >=> setField "aws.prekeyTable" resource.berAwsPrekeyTable
              >=> setField "internalEvents.queueName" resource.berBrigInternalEvents
              >=> setField "emailSMS.email.sesQueue" resource.berEmailSMSSesQueue
              >=> setField "emailSMS.general.emailSender" resource.berEmailSMSEmailSender,
          cargoholdCfg = setField "aws.s3Bucket" resource.berAwsS3Bucket,
          gundeckCfg = setField "aws.queueName" resource.berAwsQueueName,
          galleyCfg = setField "journal.queueName" resource.berGalleyJournal
        }

    setFederationSettings :: ServiceOverrides
    setFederationSettings =
      def
        { brigCfg =
            setField "optSettings.setFederationDomain" resource.berDomain
              >=> setField "optSettings.setFederationDomainConfigs" ([] :: [Value])
              >=> setField "federatorInternal.port" resource.berFederatorInternal
              >=> setField "federatorInternal.host" ("127.0.0.1" :: String)
              >=> setField "rabbitmq.vHost" resource.berVHost,
          cargoholdCfg =
            setField "settings.federationDomain" resource.berDomain
              >=> setField "federator.host" ("127.0.0.1" :: String)
              >=> setField "federator.port" resource.berFederatorInternal,
          galleyCfg =
            setField "settings.federationDomain" resource.berDomain
              >=> setField "settings.featureFlags.classifiedDomains.config.domains" [resource.berDomain]
              >=> setField "federator.host" ("127.0.0.1" :: String)
              >=> setField "federator.port" resource.berFederatorInternal
              >=> setField "rabbitmq.vHost" resource.berVHost,
          gundeckCfg =
            setField "settings.federationDomain" resource.berDomain
              >=> setField "rabbitmq.vHost" resource.berVHost,
          backgroundWorkerCfg =
            setField "federatorInternal.port" resource.berFederatorInternal
              >=> setField "federatorInternal.host" ("127.0.0.1" :: String)
              >=> setField "federationDomain" resource.berDomain
              >=> setField "rabbitmq.vHost" resource.berVHost,
          federatorInternalCfg =
            setField "federatorInternal.port" resource.berFederatorInternal
              >=> setField "federatorExternal.port" resource.berFederatorExternal
              >=> setField "optSettings.setFederationDomain" resource.berDomain,
          cannonCfg =
            setField "rabbitmq.vHost" resource.berVHost
        }

    setKeyspace :: ServiceOverrides
    setKeyspace =
      def
        { galleyCfg = setField "cassandra.keyspace" resource.berGalleyKeyspace,
          brigCfg = setField "cassandra.keyspace" resource.berBrigKeyspace,
          sparCfg = setField "cassandra.keyspace" resource.berSparKeyspace,
          gundeckCfg = setField "cassandra.keyspace" resource.berGundeckKeyspace,
          backgroundWorkerCfg =
            setField "cassandra.keyspace" resource.berGundeckKeyspace
              >=> setField "cassandraGalley.keyspace" resource.berGalleyKeyspace
              >=> setField "cassandraBrig.keyspace" resource.berBrigKeyspace,
          cannonCfg =
            setField "cassandra.keyspace" resource.berGundeckKeyspace
        }
    setPgDb :: ServiceOverrides
    setPgDb =
      def
        { brigCfg = setField "postgresql.dbname" resource.berPostgresqlDBName,
          galleyCfg = setField "postgresql.dbname" resource.berPostgresqlDBName,
          backgroundWorkerCfg = setField "postgresql.dbname" resource.berPostgresqlDBName
        }

    setEsIndex :: ServiceOverrides
    setEsIndex =
      def
        { brigCfg = setField "elasticsearch.index" resource.berElasticsearchIndex
        }

    setMlsPrivateKeyPaths :: ServiceOverrides
    setMlsPrivateKeyPaths =
      def
        { galleyCfg = \cfg -> do
            paths <- localMlsPrivateKeyPaths resource.berMlsPrivateKeyPaths
            setField "settings.mlsPrivateKeyPaths" paths cfg
        }

    localMlsPrivateKeyPaths :: Value -> App Value
    localMlsPrivateKeyPaths paths = do
      asks
        ( ( \case
              Nothing -> paths
              Just servicesCwdBase ->
                absolutizeRelativeJsonStrings (servicesCwdBase </> "galley") paths
          )
            . ((.servicesCwdBase))
        )

    -- Galley and background-worker both read this Galley config, but local
    -- binaries run with different service-specific working directories. Use
    -- absolute paths locally while leaving external/CI configs untouched.
    absolutizeRelativeJsonStrings :: FilePath -> Value -> Value
    absolutizeRelativeJsonStrings base = \case
      String path
        | isRelative (Text.unpack path) ->
            String . Text.pack . normalise $ base </> Text.unpack path
      Object objectValue ->
        Object (absolutizeRelativeJsonStrings base <$> objectValue)
      Array array ->
        Array (absolutizeRelativeJsonStrings base <$> array)
      value -> value

    setLogLevel :: ServiceOverrides
    setLogLevel =
      def
        { sparCfg = setField "saml.logLevel" ("Warn" :: String),
          brigCfg = setField "logLevel" ("Warn" :: String),
          cannonCfg = setField "logLevel" ("Warn" :: String),
          cargoholdCfg = setField "logLevel" ("Warn" :: String),
          galleyCfg = setField "logLevel" ("Warn" :: String),
          gundeckCfg = setField "logLevel" ("Warn" :: String),
          nginzCfg = setField "logLevel" ("Warn" :: String),
          backgroundWorkerCfg = setField "logLevel" ("Warn" :: String),
          sternCfg = setField "logLevel" ("Warn" :: String),
          federatorInternalCfg = setField "logLevel" ("Warn" :: String),
          wireProxyCfg = setField "logLevel" ("Warn" :: String)
        }

updateServiceMapInConfig :: BackendResource -> Service -> Value -> App Value
updateServiceMapInConfig resource forSrv config =
  foldlM
    ( \c (srv, port) -> do
        overridden <-
          c
            & setField
              (serviceName srv)
              ( object
                  ( [ "host" .= ("127.0.0.1" :: String),
                      "port" .= port
                    ]
                      <> (["externalHost" .= ("127.0.0.1" :: String) | srv == Cannon])
                  )
              )
        case (srv, forSrv) of
          (Spar, Spar) -> do
            overridden
              -- FUTUREWORK: override "saml.spAppUri" and "saml.spSsoUri" with correct port, too?
              & setField "saml.spHost" ("127.0.0.1" :: String)
              & setField "saml.spPort" port
          _ -> pure overridden
    )
    config
    [ (srv, berInternalServicePorts resource srv :: Int)
    | srv <- allServices,
      -- if a service is not enabled, do not set its endpoint configuration,
      -- unless we are starting the service itself
      berEnableService resource srv || srv == forSrv
    ]

startBackend ::
  (HasCallStack) =>
  BackendResource ->
  ServiceOverrides ->
  Codensity App ()
startBackend resource overrides = do
  lift $ waitForPortsToBeFree resource
  initRuntimeFiles <- lift $ initBackendRuntimeFiles resource overrides
  artifacts <- hoistCodensity $ Codensity $ E.bracket initRuntimeFiles cleanupBackendRuntimeFiles
  traverseConcurrentlyCodensity (withProcess artifacts resource) allServices
  lift $ ensureBackendReachable resource.berDomain

waitForPortsToBeFree :: (HasCallStack) => BackendResource -> App ()
waitForPortsToBeFree backend = do
  let namedPorts =
        (FederatorExternal, backend.berFederatorExternal)
          : (NginzHttp2, backend.berNginzHttp2Port)
          : (NginzSSL, backend.berNginzSslPort)
          : map (\s -> (ServiceInternal s, berInternalServicePorts backend s)) [minBound .. maxBound]
  void $ UnliftIO.pooledMapConcurrentlyN 8 (uncurry $ waitForPortToBeFree backend.berDomain) namedPorts

-- | Using lsof because it is most convenient. Checking if a port is free in Haskell involves binding to it which is not what we want.
waitForPortToBeFree :: String -> PortNamespace -> Word16 -> App ()
waitForPortToBeFree domain portName portNumber = do
  env <- ask
  addFailureContext ("domain=" <> domain <> "\nportName=" <> show portName <> "\nportNumber=" <> show portNumber) $
    UnliftIO.timeout (env.timeOutSeconds * 1_000_000) check >>= \case
      Nothing -> assertFailure $ "timeout waiting for federator port to be free: name=" <> show portName <> ", number=" <> show portNumber
      Just _ -> pure ()
  where
    check :: App ()
    check = do
      env <- ask
      let process = (proc "lsof" ["-Q", "-Fpc", "-i", ":" <> show portNumber, "-s", "TCP:LISTEN"]) {std_out = CreatePipe, std_err = CreatePipe}
      (_, Just stdoutHdl, Just stderrHdl, ph) <- liftIO $ createProcess process
      let prefix = "[" <> "lsof(" <> show portName <> ")@" <> domain <> maybe "" (":" <>) env.currentTestName <> "] "
      liftIO $ void $ forkIO $ logToConsole id prefix stderrHdl
      exitCode <- liftIO $ waitForProcess ph
      case exitCode of
        ExitFailure _ -> assertFailure $ prefix <> "lsof failed to figure out if port is free"
        ExitSuccess -> do
          lsofOutput <- liftIO $ hGetContents stdoutHdl
          case parseLsof (fromString lsofOutput) of
            Right procs@(_ : _) -> do
              liftIO $ putStrLn $ colored red $ prefix <> "Found one or more processes listening on port: " <> show portNumber
              analysis <- List.intercalate "\n" <$> mapM (liftIO . uncurry analyzeRunningProcess) procs
              liftIO $ putStrLn $ indent 2 analysis
              liftIO $ threadDelay 100_000
              check
            Right [] -> pure ()
            Left e -> assertFailure $ "Failed while parsing lsof output with error: " <> e <> "\n" <> "lsof output:\n" <> lsofOutput

analyzeRunningProcess :: ProcessID -> String -> IO String
analyzeRunningProcess pid pname = do
  eithSocket <- LinuxProc.readProcTcpSockets (LinuxProc.ProcessId $ fromIntegral pid)
  let sockInfo = case eithSocket of
        Left e -> "Failed to read TCP sockets for process: error: " <> Text.unpack (LinuxProc.renderProcError e)
        Right socks -> List.intercalate "\n" $ map displaySocket socks
  pure $ "Process: pid=" <> show pid <> ", name=" <> pname <> "\n" <> indent 2 sockInfo
  where
    displaySocket :: LinuxProc.TcpSocket -> String
    displaySocket sock = "local address = " <> show sock.tcpLocalAddr <> ", remote address = " <> show sock.tcpRemoteAddr <> ", tcp state = " <> show sock.tcpTcpState

-- | Example lsof output:
--
-- @
-- p61317
-- cfederator
--
-- @
parseLsof :: String -> Either String [(ProcessID, String)]
parseLsof output =
  Parser.parseOnly (listParser <* trailingSpace <* Parser.endOfInput) (fromString output)
  where
    lsofParser :: Parser.Parser (ProcessID, String)
    lsofParser =
      (,) <$> processIdParser <* Parser.char '\n' <*> processNameParser
    processIdParser = Parser.char 'p' *> Parser.decimal
    processNameParser = Parser.char 'c' *> Parser.many1 (Parser.satisfy (/= '\n'))

    listParser = (Parser.sepBy lsofParser (Parser.char '\n'))
    trailingSpace = Parser.many' (Parser.satisfy Char.isSpace)

ensureBackendReachable :: (HasCallStack) => String -> App ()
ensureBackendReachable domain = do
  env <- ask
  -- The new backend must be reachable via federation from every origin
  -- domain that will fan out to it. The migration test, for example,
  -- creates federated conversations from both 'domain1' and 'domain2', so
  -- checking ingress from 'domain1' alone (as before) leaves a race where
  -- federation from the other origin is not yet warm when the test bursts.
  let origins = [env.domain1, env.domain2]
      checkAll = and <$> traverse (\origin -> checkFederationIngress origin domain) origins
  unless (domain == env.domain1 || domain == env.domain2) $
    retryRequestUntil checkAll "Federator ingress"

-- | Probe the federator ingress from @origin@ to @target@ by issuing the
-- versioned-federation API-version RPC.  Returns 'True' on a 200 response or a
-- @533 federation-denied@ response: the latter proves that the ingress itself is
-- working even when federation between the two domains is disabled (so the
-- request reaches the target and is processed).  Any transport-level failure
-- (e.g. a cold federator connection returning 521/525/533 transport errors) is
-- treated as "not yet warm" by catching the resulting 'HTTP.HttpException'.
checkFederationIngress :: (HasCallStack) => String -> String -> App Bool
checkFederationIngress origin target = do
  req <-
    rawBaseRequest
      origin
      FederatorInternal
      Unversioned
      ("/rpc/" <> target <> "/brig/api-version")
      <&> (addHeader "Wire-Origin-Domain" origin)
        . (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)
  eith <- liftIO (E.try checkStatus)
  pure $ either (\(_e :: HTTP.HttpException) -> False) id eith

processColors :: [(String, String -> String)]
processColors =
  [ ("brig", colored green),
    ("galley", colored yellow),
    ("gundeck", colored blue),
    ("cannon", colored orange),
    ("cargohold", colored purpleish),
    ("spar", colored orange),
    ("federator", colored blue),
    ("background-worker", colored blue),
    ("nginx", colored purpleish)
  ]

data BackendRuntimeFiles = BackendRuntimeFiles
  { serviceConfigs :: Map Service FilePath,
    tempPaths :: [FilePath],
    nginzWorkingDir :: FilePath
  }

-- | Minimum cumulative budget (microseconds) to wait for a service to come up.
--
-- A service such as the background-worker cold-connects to several dependencies
-- (Cassandra x3, RabbitMQ over TLS x2) before binding its HTTP port. The fixed
-- 4s budget used previously was far too tight under CI load and caused spurious
-- "Timed out waiting for service ... to come up" failures (empty stdout/stderr
-- and no exit code, i.e. a hang in startup rather than a crash). This floor can
-- still be raised via @TEST_TIMEOUT_SECONDS@.
serviceStartupDelayFloor :: Int
serviceStartupDelayFloor = 60 * 1000 * 1000

-- | Wait for a service to come up.
waitUntilServiceIsUp :: (HasCallStack) => Maybe ProcessDebug -> String -> Service -> App ()
waitUntilServiceIsUp mDebug domain srv = do
  env <- ask
  let comeUpDelay = max serviceStartupDelayFloor (env.timeOutSeconds * 1_000_000)
  retryRequestUntilDebug
    comeUpDelay
    mDebug
    (checkServiceIsUp domain srv)
    (show srv)

-- | Check if a service is up and running.
checkServiceIsUp :: String -> Service -> App Bool
checkServiceIsUp _ Nginz = pure True
checkServiceIsUp domain srv = do
  req <- baseRequest domain srv Unversioned "/i/status"
  checkStatus <- appToIO $ do
    res <- submit "GET" req
    pure (res.status `elem` [200, 204])
  eith <- liftIO (E.try checkStatus)
  pure $ either (\(_e :: HTTP.HttpException) -> False) id eith

readAndUpdateConfig :: ServiceOverrides -> BackendResource -> Service -> App (IO Value)
readAndUpdateConfig overrides resource service =
  appToIO $
    readServiceConfig service
      >>= updateServiceMapInConfig resource service
      >>= lookupConfigOverride overrides service

data ProcessInstance = ProcessInstance {handle :: ProcessHandle, pid :: Pid}

withProcess :: (HasCallStack) => BackendRuntimeFiles -> BackendResource -> Service -> Codensity App ()
withProcess artifacts resource service = do
  env <- lift ask
  let domain = berDomain resource
      execName = configName service
      (cwd, exe) = case env.servicesCwdBase of
        Nothing -> (Nothing, execName)
        Just dir ->
          (Just (dir </> execName), "../../dist" </> execName)

  stdOut <- liftIO $ newIORef []
  stdErr <- liftIO $ newIORef []
  phRef <- liftIO $ newIORef Nothing

  let prefix = "[" <> execName <> "@" <> domain <> maybe "" (":" <>) env.currentTestName <> "] "
      initProcess = case (service, cwd) of
        (Nginz, _) ->
          startNginz domain (lookupServiceConfig Nginz artifacts) artifacts.nginzWorkingDir
        (BackgroundWorker, _) -> do
          let backgroundWorkerConf = lookupServiceConfig BackgroundWorker artifacts
              galleyConf = lookupServiceConfig Galley artifacts
              params = ["-c", backgroundWorkerConf, "--galley-config-file", galleyConf]
          createServiceInstance params
        _ -> do
          let conf = lookupServiceConfig service artifacts
              params = ["-c", conf]
          createServiceInstance params
        where
          createServiceInstance params = do
            (_, Just stdoutHdl, Just stderrHdl, ph) <- createProcess (proc exe params) {cwd = cwd, std_out = CreatePipe, std_err = CreatePipe}
            let colorize = fromMaybe id (lookup execName processColors)
            void $ forkIO $ logToConsoleDebug (Just stdOut) colorize prefix stdoutHdl
            void $ forkIO $ logToConsoleDebug (Just stdErr) colorize prefix stderrHdl
            writeIORef phRef (Just ph)
            mkProcessInstance service ph

  void $
    hoistCodensity $
      Codensity $
        E.bracket initProcess kill

  lift $
    addFailureContext ("Waiting for service: " <> prefix) $ do
      waitUntilServiceIsUp (Just $ ProcessDebug {phRef = phRef, stdOut = stdOut, stdErr = stdErr}) domain service
  where
    kill :: (HasCallStack) => ProcessInstance -> IO ()
    kill p = do
      processExists <- ignoreMissingProcess (signalProcess keyboardSignal p.pid)
      if processExists
        then
          timeout 50000 (waitForProcess p.handle) >>= \case
            Just _ -> pure ()
            Nothing -> forceKillAndWait
        else waitForProcessWithTimeout
      where
        forceKillAndWait = do
          void $ ignoreMissingProcess (signalProcess killProcess p.pid)
          waitForProcessWithTimeout

        waitForProcessWithTimeout =
          timeout 50000 (waitForProcess p.handle) >>= \case
            Just _ -> pure ()
            Nothing -> E.throw (AssertionFailure callStack Nothing Nothing "Timed out waiting for service process to terminate during cleanup")

        ignoreMissingProcess :: IO () -> IO Bool
        ignoreMissingProcess action =
          E.catch
            (action $> True)
            ( \e ->
                if isDoesNotExistError e
                  then pure False
                  else E.throwIO e
            )

        timeout usecs action = either (const Nothing) Just <$> race (threadDelay usecs) action

initBackendRuntimeFiles :: BackendResource -> ServiceOverrides -> App (IO BackendRuntimeFiles)
initBackendRuntimeFiles resource overrides = appToIO do
  serviceConfigs <- prepareConfigFiles $ filter (/= Nginz) allServices
  (nginzConf, nginzTempDir, nginzWorkingDir) <- prepareNginzRuntimeFiles resource
  pure $
    BackendRuntimeFiles
      { serviceConfigs = Map.insert Nginz nginzConf serviceConfigs,
        tempPaths = nginzTempDir : Map.elems serviceConfigs,
        nginzWorkingDir = nginzWorkingDir
      }
  where
    prepareConfigFiles services = Map.fromList <$> traverse getAndWrite services

    getAndWrite :: Service -> App (Service, FilePath)
    getAndWrite service = do
      getConfig <- readAndUpdateConfig overrides resource service
      config <- liftIO getConfig
      tempFile <- liftIO $ writeTempFile "/tmp" (configName service <> "-" <> resource.berDomain <> "-" <> ".yaml") (cs $ Yaml.encode config)
      pure (service, tempFile)

cleanupBackendRuntimeFiles :: BackendRuntimeFiles -> IO ()
cleanupBackendRuntimeFiles artifacts = for_ artifacts.tempPaths \path -> do
  whenM (doesFileExist path) $ removeFile path
  whenM (doesDirectoryExist path) $ removeDirectoryRecursive path

lookupServiceConfig :: Service -> BackendRuntimeFiles -> FilePath
lookupServiceConfig service artifacts =
  fromMaybe (error $ "missing backend artifact for service " <> show service) $
    Map.lookup service artifacts.serviceConfigs

logToConsole :: (String -> String) -> String -> Handle -> IO ()
logToConsole = logToConsoleDebug Nothing

logToConsoleDebug :: Maybe (IORef [String]) -> (String -> String) -> String -> Handle -> IO ()
logToConsoleDebug mOutput colorize prefix hdl = do
  let go =
        do
          line <- hGetLine hdl
          putStrLn (colorize (prefix <> line))
          case mOutput of
            Nothing -> pure ()
            Just output -> do
              modifyIORef output (<> [line])
          go
          `E.catch` (\(_ :: E.IOException) -> pure ())
  go

-- | Cumulative budget (microseconds) for the federator-ingress readiness
-- checks. A freshly started
-- backend may need a few TLS handshakes before it answers federated calls
-- reliably.
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.
warmupFederation :: (HasCallStack) => App ()
warmupFederation = do
  env <- ask
  let checkBoth =
        and
          <$> traverse
            (uncurry checkFederationIngress)
            [(env.domain1, env.domain2), (env.domain2, env.domain1)]
  retryRequestUntil checkBoth "Static federator ingress (domain1 <-> domain2)"

retryRequestUntil :: (HasCallStack) => ((HasCallStack) => App Bool) -> String -> App ()
retryRequestUntil = retryRequestUntilDebug federatorIngressDelay Nothing

data ProcessDebug = ProcessDebug
  { phRef :: IORef (Maybe ProcessHandle),
    stdOut :: IORef [String],
    stdErr :: IORef [String]
  }

retryRequestUntilDebug :: (HasCallStack) => Int -> Maybe ProcessDebug -> ((HasCallStack) => App Bool) -> String -> App ()
retryRequestUntilDebug comeUpDelay mProcessDebug reqAction err = do
  isUp <-
    retrying
      (limitRetriesByCumulativeDelay comeUpDelay (fibonacciBackoff (200 * 1000)))
      (\_ isUp -> pure (not isUp))
      (const reqAction)
  unless isUp $ do
    case mProcessDebug of
      Nothing ->
        assertFailure ("Timed out waiting for service " <> err <> " to come up")
      Just (ProcessDebug {..}) -> do
        stdOut' <- liftIO $ readIORef stdOut
        stdErr' <- liftIO $ readIORef stdErr
        mPh <- liftIO $ readIORef phRef
        let stdOutStr = List.intercalate "\n" stdOut'
            stdErrStr = List.intercalate "\n" stdErr'
        mExitCode <- maybe (pure Nothing) (liftIO . getProcessExitCode) mPh
        let msg =
              "Timed out waiting for service "
                <> err
                <> " to come up\n"
                <> "stdout:\n"
                <> stdOutStr
                <> "\nstderr:\n"
                <> stdErrStr
                <> "\nexitCode:\n"
                <> show (maybe "no exit code" show mExitCode)
        addFailureContext msg $
          assertFailure msg

prepareNginzRuntimeFiles :: BackendResource -> App (FilePath, FilePath, FilePath)
prepareNginzRuntimeFiles resource = do
  let domain = berDomain resource
  sm <- getServiceMap domain
  mBaseDir <- asks (.servicesCwdBase)
  case mBaseDir of
    Nothing -> liftIO $ prepareNginzK8sRuntimeFiles sm
    Just basedir -> liftIO $ prepareNginzLocalRuntimeFiles resource sm basedir

prepareNginzK8sRuntimeFiles :: ServiceMap -> IO (FilePath, FilePath, FilePath)
prepareNginzK8sRuntimeFiles sm = do
  tmpDir <- createTempDirectory "/tmp" "nginz-"
  copyDirectoryRecursively "/etc/wire/nginz/" tmpDir

  let nginxConfFile = tmpDir </> "conf" </> "nginx.conf"
  conf <- Text.readFile nginxConfFile
  let conf' =
        conf
          & Text.replace "access_log /dev/stdout" "access_log /dev/null"
          -- FUTUREWORK: Get these ports out of config
          & Text.replace ("listen 8080;\n    listen 8081 proxy_protocol;") (cs $ "listen " <> show sm.nginz.port <> ";")
          & Text.replace ("listen 8082;") (cs $ "listen unix:" <> (tmpDir </> "metrics-socket") <> ";")
          & Text.replace ("/var/run/nginz.pid") (cs $ tmpDir </> "nginz.pid")

  Text.writeFile nginxConfFile $ replaceUpstreamsInConfig conf' sm

  pure (nginxConfFile, tmpDir, "/")

prepareNginzLocalRuntimeFiles :: BackendResource -> ServiceMap -> FilePath -> IO (FilePath, FilePath, FilePath)
prepareNginzLocalRuntimeFiles resource sm basedir = do
  -- Create a whole temporary directory and copy all nginx's config files.
  -- This is necessary because nginx assumes local imports are relative to
  -- the location of the main configuration file.
  tmpDir <- createTempDirectory "/tmp" "nginz-"

  -- copy all config files into the tmp dir
  let from = basedir </> "nginz" </> "integration-test"
  copyDirectoryRecursively (from </> "conf" </> "nginz") (tmpDir </> "conf" </> "nginz")
  copyDirectoryRecursively (from </> "resources") (tmpDir </> "resources")

  -- hide access log
  let nginxConfFile = tmpDir </> "conf" </> "nginz" </> "nginx.conf"
  conf <- Text.readFile nginxConfFile
  Text.writeFile nginxConfFile $
    ( conf
        & Text.replace "access_log /dev/stdout" "access_log /dev/null"
    )

  -- override port configuration
  let nginzPort = sm.nginz.port
      http2Port = berNginzHttp2Port resource
      sslPort = berNginzSslPort resource
      portConfig =
        [i|listen #{nginzPort};
            listen #{http2Port};
            listen #{sslPort} ssl;
            listen [::]:#{sslPort} ssl;
            http2 on;
        |]
      integrationConfFile = tmpDir </> "conf" </> "nginz" </> "integration.conf"

  whenM (doesFileExist integrationConfFile) $ removeFile integrationConfFile
  writeFile integrationConfFile portConfig

  -- override upstreams
  let upstreamsCfg = tmpDir </> "conf" </> "nginz" </> "upstreams"

  whenM (doesFileExist upstreamsCfg) $
    removeFile upstreamsCfg
  writeFile upstreamsCfg (makeUpstreamsCfgs sm)

  -- override pid configuration
  let pidConfigFile = tmpDir </> "conf" </> "nginz" </> "pid.conf"
  let pid = tmpDir </> "conf" </> "nginz" </> "nginz.pid"
  whenM (doesFileExist $ pidConfigFile) $ removeFile pidConfigFile
  writeFile pidConfigFile (cs $ "pid " <> pid <> ";")

  pure (nginxConfFile, tmpDir, tmpDir)

makeUpstreamsCfgs :: ServiceMap -> String
makeUpstreamsCfgs sm =
  let upstreamTemplate _name _port =
        [i|upstream #{_name} {
            least_conn;
            keepalive 32;
            server 127.0.0.1:#{_port} max_fails=3 weight=1;
            }
        |]
   in concat
        $ (flip map)
          [ (serviceName Brig, sm.brig.port),
            (serviceName Cannon, sm.cannon.port),
            (serviceName Cargohold, sm.cargohold.port),
            (serviceName Galley, sm.galley.port),
            (serviceName Gundeck, sm.gundeck.port),
            (serviceName Nginz, sm.nginz.port),
            (serviceName WireProxy, sm.proxy.port),
            (serviceName Spar, sm.spar.port),
            ("federator_external", sm.federatorExternal.port)
          ]
        $ uncurry upstreamTemplate

-- | replace 'upstream <name> { ... }' blocks
replaceUpstreamsInConfig :: Text.Text -> ServiceMap -> Text.Text
replaceUpstreamsInConfig nginxConf sm =
  insertGeneratedUpstreams generateUpstreamsText $ removeUpstreamBlocks
  where
    -- remove blocks like:
    --
    -- upstream <name> {
    --   ...
    --   <config>
    --   ...
    -- }
    --
    -- Prerequisite is that the upstream  block itself does not contain block
    -- delimiters. AFAIK this usually holds.
    removeUpstreamBlocks :: Text.Text
    removeUpstreamBlocks =
      replaceAll "" $
        -- regex-tdfa does unfortunately not support shorthands for character classes.
        -- regex-tdfa does unfortunately not support shorthands for character classes.
        -- regex-tdfa does unfortunately not support shorthands for character classes.
        nginxConf *=~ [re|upstream[[:blank:]]+[[:word:]]+([[:blank:]]|[[:cntrl:]])+{([^}]|[[:cntrl:]])+}|]

    -- Insert generated upstreams:
    -- Try to put them right after the opening 'http {'.
    insertGeneratedUpstreams :: Text.Text -> Text.Text -> Text.Text
    insertGeneratedUpstreams ups conf =
      case Text.breakOn "http {" conf of
        (pre, rest)
          | not (Text.null rest) ->
              let (httpOpen, postOpen) = Text.splitAt (Text.length "http {") rest
               in Text.concat [pre, httpOpen, "\n\n", ups, postOpen]
        _ -> Text.concat [ups, "\n", conf]

    generateUpstreamsText :: Text.Text
    generateUpstreamsText =
      Text.concat $
        [ (serviceName Brig, sm.brig.port),
          (serviceName Cannon, sm.cannon.port),
          (serviceName Cargohold, sm.cargohold.port),
          (serviceName Galley, sm.galley.port),
          (serviceName Gundeck, sm.gundeck.port),
          (serviceName Nginz, sm.nginz.port),
          (serviceName WireProxy, sm.proxy.port),
          (serviceName Spar, sm.spar.port)
        ]
          <&> Text.pack . uncurry upstreamTemplate
      where
        upstreamTemplate _name _port =
          [i|upstream #{_name} {
              least_conn;
              keepalive 32;
              server 127.0.0.1:#{_port} max_fails=3 weight=1;
              }
          |]

mkProcessInstance :: Service -> ProcessHandle -> IO ProcessInstance
mkProcessInstance service ph = do
  mPid <- getPid ph
  case mPid of
    Just pid -> pure $ ProcessInstance ph pid
    Nothing -> E.throw (AssertionFailure callStack Nothing Nothing (configName service <> " started without a pid"))

startNginz :: String -> FilePath -> FilePath -> IO ProcessInstance
startNginz domain conf workingDir = do
  (_, Just stdoutHdl, Just stderrHdl, ph) <-
    createProcess
      (proc "nginx" ["-c", conf, "-g", "daemon off;", "-e", "/dev/stdout"])
        { cwd = Just workingDir,
          std_out = CreatePipe,
          std_err = CreatePipe
        }

  let prefix = "[" <> "nginz" <> "@" <> domain <> "] "
  let colorize = fromMaybe id (lookup "nginx" processColors)

  void $ forkIO $ logToConsole colorize prefix stdoutHdl
  void $ forkIO $ logToConsole colorize prefix stderrHdl
  mkProcessInstance Nginz ph
