{-# 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,
    readAndUpdateConfig,
    logToConsole,
  )
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.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.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 :: forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend ServiceOverrides
overrides HasCallStack => String -> App a
k =
  [ServiceOverrides] -> ([String] -> App a) -> App a
forall a.
HasCallStack =>
[ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends [ServiceOverrides
overrides] (\[String
domains] -> HasCallStack => String -> App a
String -> App a
k String
domains)

copyDirectoryRecursively :: FilePath -> FilePath -> IO ()
copyDirectoryRecursively :: String -> String -> IO ()
copyDirectoryRecursively String
from String
to = do
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
to
  files <- String -> IO [String]
listDirectory String
from
  for_ files $ \String
file -> do
    let fromPath :: String
fromPath = String
from String -> String -> String
</> String
file
    let toPath :: String
toPath = String
to String -> String -> String
</> String
file
    isDirectory <- String -> IO Bool
doesDirectoryExist String
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 :: forall a.
(HasCallStack => a -> Codensity App ())
-> HasCallStack => [a] -> Codensity App ()
traverseConcurrentlyCodensity HasCallStack => a -> Codensity App ()
f [a]
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 <- IO [(MVar (Maybe SomeException), MVar ())]
-> Codensity App [(MVar (Maybe SomeException), MVar ())]
forall a. IO a -> Codensity App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(MVar (Maybe SomeException), MVar ())]
 -> Codensity App [(MVar (Maybe SomeException), MVar ())])
-> IO [(MVar (Maybe SomeException), MVar ())]
-> Codensity App [(MVar (Maybe SomeException), MVar ())]
forall a b. (a -> b) -> a -> b
$ [a]
-> (a -> IO (MVar (Maybe SomeException), MVar ()))
-> IO [(MVar (Maybe SomeException), MVar ())]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [a]
args ((a -> IO (MVar (Maybe SomeException), MVar ()))
 -> IO [(MVar (Maybe SomeException), MVar ())])
-> (a -> IO (MVar (Maybe SomeException), MVar ()))
-> IO [(MVar (Maybe SomeException), MVar ())]
forall a b. (a -> b) -> a -> b
$ \a
_ -> do
    result <- IO (MVar (Maybe SomeException))
forall a. IO (MVar a)
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 $ \((MVar (Maybe SomeException)
result, MVar ()
done), a
arg) ->
    App () -> (SomeException -> App ()) -> App ()
forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch
      ( Codensity App () -> forall b. (() -> App b) -> App b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (a -> Codensity App ()
HasCallStack => a -> Codensity App ()
f a
arg) ((() -> App ()) -> App ()) -> (() -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \()
_ -> IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> IO () -> App ()
forall a b. (a -> b) -> a -> b
$ do
          MVar (Maybe SomeException) -> Maybe SomeException -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe SomeException)
result Maybe SomeException
forall a. Maybe a
Nothing
          MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done
      )
      ((SomeException -> App ()) -> App ())
-> (SomeException -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: E.SomeException) ->
        App Bool -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Bool -> App ()) -> (IO Bool -> App Bool) -> IO Bool -> App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bool -> App Bool
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> App ()) -> IO Bool -> App ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe SomeException) -> Maybe SomeException -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar (Maybe SomeException)
result (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
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) $ \((MVar (Maybe SomeException), MVar ()), a)
x ->
    Codensity IO (Async ()) -> Codensity App (Async ())
forall a. Codensity IO a -> Codensity App a
hoistCodensity (Codensity IO (Async ()) -> Codensity App (Async ()))
-> Codensity IO (Async ()) -> Codensity App (Async ())
forall a b. (a -> b) -> a -> b
$ (forall b. (Async () -> IO b) -> IO b) -> Codensity IO (Async ())
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (Async () -> IO b) -> IO b) -> Codensity IO (Async ()))
-> (forall b. (Async () -> IO b) -> IO b)
-> Codensity IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> (Async () -> IO b) -> IO b
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (((MVar (Maybe SomeException), MVar ()), a) -> IO ()
runAction ((MVar (Maybe SomeException), MVar ()), a)
x)

  -- Wait for all the threads set their result variables. Any exception is
  -- rethrown here, and aborts the overall function.
  liftIO $ for_ vars $ \(MVar (Maybe SomeException)
result, MVar ()
_) ->
    MVar (Maybe SomeException) -> IO (Maybe SomeException)
forall a. MVar a -> IO a
takeMVar MVar (Maybe SomeException)
result IO (Maybe SomeException) -> (Maybe SomeException -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (SomeException -> IO ()) -> Maybe SomeException -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM

  Codensity $ \() -> App b
k -> do
    -- Now run the main continuation.
    result <- () -> App b
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_ (\(MVar (Maybe SomeException)
_, MVar ()
d) -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
d ()) vars
    liftIO $ traverse_ wait asyncs

    pure result

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

startDynamicBackendsReturnResources :: (HasCallStack) => [ServiceOverrides] -> ([BackendResource] -> App a) -> App a
startDynamicBackendsReturnResources :: forall a.
HasCallStack =>
[ServiceOverrides] -> ([BackendResource] -> App a) -> App a
startDynamicBackendsReturnResources [ServiceOverrides]
beOverrides [BackendResource] -> App a
k = do
  let startDynamicBackendsCodensity :: Codensity App [BackendResource]
startDynamicBackendsCodensity = do
        Bool -> Codensity App () -> Codensity App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ServiceOverrides] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [ServiceOverrides]
beOverrides Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (Codensity App () -> Codensity App ())
-> Codensity App () -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ App () -> Codensity App ()
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App () -> Codensity App ()) -> App () -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ String -> App ()
forall a. HasCallStack => String -> App a
failApp String
"Too many backends. Currently only 3 are supported."
        pool <- (Env -> ResourcePool BackendResource)
-> Codensity App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.resourcePool)
        resources <- acquireResources (Prelude.length beOverrides) pool
        void $
          traverseConcurrentlyCodensity
            (void . uncurry startDynamicBackend)
            (zip resources beOverrides)
        pure resources
  Codensity App [BackendResource]
-> forall b. ([BackendResource] -> App b) -> App b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity Codensity App [BackendResource]
startDynamicBackendsCodensity [BackendResource] -> App a
k

startDynamicBackend :: (HasCallStack) => BackendResource -> ServiceOverrides -> Codensity App String
startDynamicBackend :: HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App String
startDynamicBackend BackendResource
resource ServiceOverrides
beOverrides = do
  let overrides :: ServiceOverrides
overrides =
        [ServiceOverrides] -> ServiceOverrides
forall a. Monoid a => [a] -> a
mconcat
          [ ServiceOverrides
setKeyspace,
            ServiceOverrides
setEsIndex,
            ServiceOverrides
setPgDb,
            ServiceOverrides
setFederationSettings,
            ServiceOverrides
setAwsConfigs,
            ServiceOverrides
setMlsPrivateKeyPaths,
            ServiceOverrides
setLogLevel,
            ServiceOverrides
beOverrides
          ]
  HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App ()
BackendResource -> ServiceOverrides -> Codensity App ()
startBackend BackendResource
resource ServiceOverrides
overrides
  String -> Codensity App String
forall a. a -> Codensity App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BackendResource
resource.berDomain
  where
    setAwsConfigs :: ServiceOverrides
    setAwsConfigs :: ServiceOverrides
setAwsConfigs =
      ServiceOverrides
forall a. Default a => a
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 :: ServiceOverrides
setFederationSettings =
      ServiceOverrides
forall a. Default a => a
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 :: ServiceOverrides
setKeyspace =
      ServiceOverrides
forall a. Default a => a
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,
          cannonCfg =
            setField "cassandra.keyspace" resource.berGundeckKeyspace
        }
    setPgDb :: ServiceOverrides
    setPgDb :: ServiceOverrides
setPgDb =
      ServiceOverrides
forall a. Default a => a
def
        { brigCfg = setField "postgresql.dbname" resource.berPostgresqlDBName,
          galleyCfg = setField "postgresql.dbname" resource.berPostgresqlDBName,
          backgroundWorkerCfg = setField "postgresql.dbname" resource.berPostgresqlDBName
        }

    setEsIndex :: ServiceOverrides
    setEsIndex :: ServiceOverrides
setEsIndex =
      ServiceOverrides
forall a. Default a => a
def
        { brigCfg = setField "elasticsearch.index" resource.berElasticsearchIndex
        }

    setMlsPrivateKeyPaths :: ServiceOverrides
    setMlsPrivateKeyPaths :: ServiceOverrides
setMlsPrivateKeyPaths =
      ServiceOverrides
forall a. Default a => a
def
        { galleyCfg = setField "settings.mlsPrivateKeyPaths" resource.berMlsPrivateKeyPaths
        }

    setLogLevel :: ServiceOverrides
    setLogLevel :: ServiceOverrides
setLogLevel =
      ServiceOverrides
forall a. Default a => a
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 :: BackendResource -> Service -> Value -> App Value
updateServiceMapInConfig BackendResource
resource Service
forSrv Value
config =
  (Value -> (Service, Int) -> App Value)
-> Value -> [(Service, Int)] -> App Value
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
    ( \Value
c (Service
srv, Int
port) -> do
        overridden <-
          Value
c
            Value -> (Value -> App Value) -> App Value
forall a b. a -> (a -> b) -> b
& String -> Value -> Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField
              (Service -> String
serviceName Service
srv)
              ( [Pair] -> Value
object
                  ( [ String
"host" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"127.0.0.1" :: String),
                      String
"port" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Int
port
                    ]
                      [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> ([String
"externalHost" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"127.0.0.1" :: String) | Service
srv Service -> Service -> Bool
forall a. Eq a => a -> a -> Bool
== Service
Cannon])
                  )
              )
        case (srv, forSrv) of
          (Service
Spar, Service
Spar) -> do
            Value
overridden
              -- FUTUREWORK: override "saml.spAppUri" and "saml.spSsoUri" with correct port, too?
              Value -> (Value -> App Value) -> App Value
forall a b. a -> (a -> b) -> b
& String -> String -> Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
"saml.spHost" (String
"127.0.0.1" :: String)
              App Value -> (App Value -> App Value) -> App Value
forall a b. a -> (a -> b) -> b
& String -> Int -> App Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
"saml.spPort" Int
port
          (Service, Service)
_ -> Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
overridden
    )
    Value
config
    [ (Service
srv, BackendResource -> forall a. Num a => Service -> a
berInternalServicePorts BackendResource
resource Service
srv :: Int)
      | Service
srv <- [Service]
allServices,
        -- if a service is not enabled, do not set its endpoint configuration,
        -- unless we are starting the service itself
        BackendResource -> Service -> Bool
berEnableService BackendResource
resource Service
srv Bool -> Bool -> Bool
|| Service
srv Service -> Service -> Bool
forall a. Eq a => a -> a -> Bool
== Service
forSrv
    ]

startBackend ::
  (HasCallStack) =>
  BackendResource ->
  ServiceOverrides ->
  Codensity App ()
startBackend :: HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App ()
startBackend BackendResource
resource ServiceOverrides
overrides = do
  App () -> Codensity App ()
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App () -> Codensity App ()) -> App () -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => BackendResource -> App ()
BackendResource -> App ()
waitForPortsToBeFree BackendResource
resource
  (HasCallStack => Service -> Codensity App ())
-> HasCallStack => [Service] -> Codensity App ()
forall a.
(HasCallStack => a -> Codensity App ())
-> HasCallStack => [a] -> Codensity App ()
traverseConcurrentlyCodensity (HasCallStack =>
BackendResource -> ServiceOverrides -> Service -> Codensity App ()
BackendResource -> ServiceOverrides -> Service -> Codensity App ()
withProcess BackendResource
resource ServiceOverrides
overrides) [Service]
allServices
  App () -> Codensity App ()
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App () -> Codensity App ()) -> App () -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> App ()
String -> App ()
ensureBackendReachable BackendResource
resource.berDomain

waitForPortsToBeFree :: (HasCallStack) => BackendResource -> App ()
waitForPortsToBeFree :: HasCallStack => BackendResource -> App ()
waitForPortsToBeFree BackendResource
backend = do
  let namedPorts :: [(PortNamespace, Word16)]
namedPorts =
        (PortNamespace
FederatorExternal, BackendResource
backend.berFederatorExternal)
          (PortNamespace, Word16)
-> [(PortNamespace, Word16)] -> [(PortNamespace, Word16)]
forall a. a -> [a] -> [a]
: (PortNamespace
NginzHttp2, BackendResource
backend.berNginzHttp2Port)
          (PortNamespace, Word16)
-> [(PortNamespace, Word16)] -> [(PortNamespace, Word16)]
forall a. a -> [a] -> [a]
: (PortNamespace
NginzSSL, BackendResource
backend.berNginzSslPort)
          (PortNamespace, Word16)
-> [(PortNamespace, Word16)] -> [(PortNamespace, Word16)]
forall a. a -> [a] -> [a]
: (Service -> (PortNamespace, Word16))
-> [Service] -> [(PortNamespace, Word16)]
forall a b. (a -> b) -> [a] -> [b]
map (\Service
s -> (Service -> PortNamespace
ServiceInternal Service
s, BackendResource -> forall a. Num a => Service -> a
berInternalServicePorts BackendResource
backend Service
s)) [Service
forall a. Bounded a => a
minBound .. Service
forall a. Bounded a => a
maxBound]
  App [()] -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App [()] -> App ()) -> App [()] -> App ()
forall a b. (a -> b) -> a -> b
$ Int
-> ((PortNamespace, Word16) -> App ())
-> [(PortNamespace, Word16)]
-> App [()]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
Int -> (a -> m b) -> t a -> m (t b)
UnliftIO.pooledMapConcurrentlyN Int
8 ((PortNamespace -> Word16 -> App ())
-> (PortNamespace, Word16) -> App ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((PortNamespace -> Word16 -> App ())
 -> (PortNamespace, Word16) -> App ())
-> (PortNamespace -> Word16 -> App ())
-> (PortNamespace, Word16)
-> App ()
forall a b. (a -> b) -> a -> b
$ String -> PortNamespace -> Word16 -> App ()
waitForPortToBeFree BackendResource
backend.berDomain) [(PortNamespace, Word16)]
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 :: String -> PortNamespace -> Word16 -> App ()
waitForPortToBeFree String
domain PortNamespace
portName Word16
portNumber = do
  env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  addFailureContext ("domain=" <> domain <> "\nportName=" <> show portName <> "\nportNumber=" <> show portNumber) $
    UnliftIO.timeout (env.timeOutSeconds * 1_000_000) check >>= \case
      Maybe ()
Nothing -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"timeout waiting for federator port to be free: name=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PortNamespace -> String
forall a. Show a => a -> String
show PortNamespace
portName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", number=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word16 -> String
forall a. Show a => a -> String
show Word16
portNumber
      Just ()
_ -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    check :: App ()
    check :: App ()
check = do
      env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
      let process = (String -> [String] -> CreateProcess
proc String
"lsof" [String
"-Q", String
"-Fpc", String
"-i", String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word16 -> String
forall a. Show a => a -> String
show Word16
portNumber, String
"-s", String
"TCP:LISTEN"]) {std_out = CreatePipe, std_err = CreatePipe}
      (_, Just stdoutHdl, Just stderrHdl, ph) <- liftIO $ createProcess process
      let prefix = String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"lsof(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PortNamespace -> String
forall a. Show a => a -> String
show PortNamespace
portName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
domain String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) Env
env.currentTestName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] "
      liftIO $ void $ forkIO $ logToConsole id prefix stderrHdl
      exitCode <- liftIO $ waitForProcess ph
      case exitCode of
        ExitFailure Int
_ -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"lsof failed to figure out if port is free"
        ExitCode
ExitSuccess -> do
          lsofOutput <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetContents Handle
stdoutHdl
          case parseLsof (fromString lsofOutput) of
            Right procs :: [(ProcessID, String)]
procs@((ProcessID, String)
_ : [(ProcessID, String)]
_) -> do
              IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> IO () -> App ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
red (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Found one or more processes listening on port: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word16 -> String
forall a. Show a => a -> String
show Word16
portNumber
              analysis <- String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" ([String] -> String) -> App [String] -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ProcessID, String) -> App String)
-> [(ProcessID, String)] -> App [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String)
-> ((ProcessID, String) -> IO String)
-> (ProcessID, String)
-> App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProcessID -> String -> IO String)
-> (ProcessID, String) -> IO String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ProcessID -> String -> IO String
analyzeRunningProcess) [(ProcessID, String)]
procs
              liftIO $ putStrLn $ indent 2 analysis
              liftIO $ threadDelay 100_000
              check
            Right [] -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Left String
e -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"Failed while parsing lsof output with error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"lsof output:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
lsofOutput

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

-- | Example lsof output:
--
-- @
-- p61317
-- cfederator
--
-- @
parseLsof :: String -> Either String [(ProcessID, String)]
parseLsof :: String -> Either String [(ProcessID, String)]
parseLsof String
output =
  Parser [(ProcessID, String)]
-> Text -> Either String [(ProcessID, String)]
forall a. Parser a -> Text -> Either String a
Parser.parseOnly (Parser [(ProcessID, String)]
listParser Parser [(ProcessID, String)]
-> Parser Text String -> Parser [(ProcessID, String)]
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text String
trailingSpace Parser [(ProcessID, String)]
-> Parser Text () -> Parser [(ProcessID, String)]
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
Parser.endOfInput) (String -> Text
forall a. IsString a => String -> a
fromString String
output)
  where
    lsofParser :: Parser.Parser (ProcessID, String)
    lsofParser :: Parser (ProcessID, String)
lsofParser =
      (,) (ProcessID -> String -> (ProcessID, String))
-> Parser Text ProcessID
-> Parser Text (String -> (ProcessID, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text ProcessID
processIdParser Parser Text (String -> (ProcessID, String))
-> Parser Text Char -> Parser Text (String -> (ProcessID, String))
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
Parser.char Char
'\n' Parser Text (String -> (ProcessID, String))
-> Parser Text String -> Parser (ProcessID, String)
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text String
processNameParser
    processIdParser :: Parser Text ProcessID
processIdParser = Char -> Parser Text Char
Parser.char Char
'p' Parser Text Char -> Parser Text ProcessID -> Parser Text ProcessID
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ProcessID
forall a. Integral a => Parser a
Parser.decimal
    processNameParser :: Parser Text String
processNameParser = Char -> Parser Text Char
Parser.char Char
'c' Parser Text Char -> Parser Text String -> Parser Text String
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char -> Parser Text String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Parser.many1 ((Char -> Bool) -> Parser Text Char
Parser.satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n'))

    listParser :: Parser [(ProcessID, String)]
listParser = (Parser (ProcessID, String)
-> Parser Text Char -> Parser [(ProcessID, String)]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
Parser.sepBy Parser (ProcessID, String)
lsofParser (Char -> Parser Text Char
Parser.char Char
'\n'))
    trailingSpace :: Parser Text String
trailingSpace = Parser Text Char -> Parser Text String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Parser.many' ((Char -> Bool) -> Parser Text Char
Parser.satisfy Char -> Bool
Char.isSpace)

ensureBackendReachable :: (HasCallStack) => String -> App ()
ensureBackendReachable :: HasCallStack => String -> App ()
ensureBackendReachable String
domain = do
  env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  let checkServiceIsUpReq :: (HasCallStack) => App Bool
      checkServiceIsUpReq = do
        req <-
          String -> Service -> Versioned -> String -> App Request
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Service -> Versioned -> String -> App Request
rawBaseRequest
            Env
env.domain1
            Service
FederatorInternal
            Versioned
Unversioned
            (String
"/rpc/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
domain String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/brig/api-version")
            App Request -> (Request -> Request) -> App Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> Request -> Request
addHeader String
"Wire-Origin-Domain" Env
env.domain1)
              (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Pair] -> Request -> Request
addJSONObject [])
        checkStatus <- appToIO $ do
          res <- submit "POST" req

          -- If we get 533 here it means federation is not available between domains
          -- but ingress is working, since we're processing the request.
          let is200 = Response
res.status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200
          mInner <- lookupField res.json "inner"
          isFedDenied <- case mInner of
            Maybe Value
Nothing -> Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            Just Value
inner -> do
              label <- Value
inner Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
              pure $ res.status == 533 && label == "federation-denied"

          pure (is200 || isFedDenied)
        eith <- liftIO (E.try checkStatus)
        pure $ either (\(HttpException
_e :: HTTP.HttpException) -> Bool
False) id eith

  when ((domain /= env.domain1) && (domain /= env.domain2)) $ do
    retryRequestUntil checkServiceIsUpReq "Federator ingress"

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

data ServiceInstance = ServiceInstance
  { ServiceInstance -> ProcessHandle
handle :: ProcessHandle,
    ServiceInstance -> String
config :: FilePath
  }

timeout :: Int -> IO a -> IO (Maybe a)
timeout :: forall a. Int -> IO a -> IO (Maybe a)
timeout Int
usecs IO a
action = (() -> Maybe a) -> (a -> Maybe a) -> Either () a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> () -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either () a -> Maybe a) -> IO (Either () a) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO a -> IO (Either () a)
forall a b. IO a -> IO b -> IO (Either a b)
race (Int -> IO ()
threadDelay Int
usecs) IO a
action

cleanupService :: (HasCallStack) => ServiceInstance -> IO ()
cleanupService :: HasCallStack => ServiceInstance -> IO ()
cleanupService ServiceInstance
inst = do
  mPid <- ProcessHandle -> IO (Maybe ProcessID)
getPid ServiceInstance
inst.handle
  for_ mPid (signalProcess keyboardSignal)
  timeout 50000 (waitForProcess inst.handle) >>= \case
    Just ExitCode
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe ExitCode
Nothing -> do
      Maybe ProcessID -> (ProcessID -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ProcessID
mPid (Signal -> ProcessID -> IO ()
signalProcess Signal
killProcess)
      IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess ServiceInstance
inst.handle
  whenM (doesFileExist inst.config) $ removeFile inst.config
  whenM (doesDirectoryExist inst.config) $ removeDirectoryRecursive inst.config

-- | Wait for a service to come up.
waitUntilServiceIsUp :: (HasCallStack) => Maybe ProcessDebug -> String -> Service -> App ()
waitUntilServiceIsUp :: HasCallStack => Maybe ProcessDebug -> String -> Service -> App ()
waitUntilServiceIsUp Maybe ProcessDebug
mDebug String
domain Service
srv =
  HasCallStack =>
Maybe ProcessDebug
-> (HasCallStack => App Bool) -> String -> App ()
Maybe ProcessDebug
-> (HasCallStack => App Bool) -> String -> App ()
retryRequestUntilDebug
    Maybe ProcessDebug
mDebug
    (String -> Service -> App Bool
checkServiceIsUp String
domain Service
srv)
    (Service -> String
forall a. Show a => a -> String
show Service
srv)

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

readAndUpdateConfig :: ServiceOverrides -> BackendResource -> Service -> App (IO Value)
readAndUpdateConfig :: ServiceOverrides -> BackendResource -> Service -> App (IO Value)
readAndUpdateConfig ServiceOverrides
overrides BackendResource
resource Service
service =
  App Value -> App (IO Value)
forall a. App a -> App (IO a)
appToIO (App Value -> App (IO Value)) -> App Value -> App (IO Value)
forall a b. (a -> b) -> a -> b
$
    Service -> App Value
readServiceConfig Service
service
      App Value -> (Value -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BackendResource -> Service -> Value -> App Value
updateServiceMapInConfig BackendResource
resource Service
service
      App Value -> (Value -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ServiceOverrides -> Service -> Value -> App Value
lookupConfigOverride ServiceOverrides
overrides Service
service

withProcess :: (HasCallStack) => BackendResource -> ServiceOverrides -> Service -> Codensity App ()
withProcess :: HasCallStack =>
BackendResource -> ServiceOverrides -> Service -> Codensity App ()
withProcess BackendResource
resource ServiceOverrides
overrides Service
service = do
  let domain :: String
domain = BackendResource -> String
berDomain BackendResource
resource
  sm <- App ServiceMap -> Codensity App ServiceMap
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App ServiceMap -> Codensity App ServiceMap)
-> App ServiceMap -> Codensity App ServiceMap
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> App ServiceMap
String -> App ServiceMap
getServiceMap String
domain
  env <- lift ask
  let execName = Service -> String
configName Service
service
  let (cwd, exe) = case env.servicesCwdBase of
        Maybe String
Nothing -> (Maybe String
forall a. Maybe a
Nothing, String
execName)
        Just String
dir ->
          (String -> Maybe String
forall a. a -> Maybe a
Just (String
dir String -> String -> String
</> String
execName), String
"../../dist" String -> String -> String
</> String
execName)

  startNginzLocalIO <- lift $ appToIO $ startNginzLocal resource

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

  getConfig <- lift $ readAndUpdateConfig overrides resource service
  let prefix = String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
execName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
domain String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) Env
env.currentTestName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] "
  let initProcess = case (Service
service, Maybe String
cwd) of
        (Service
Nginz, Maybe String
Nothing) -> String -> ServiceMap -> IO ServiceInstance
startNginzK8s String
domain ServiceMap
sm
        (Service
Nginz, Just String
_) -> IO ServiceInstance
startNginzLocalIO
        (Service, Maybe String)
_ -> do
          config <- IO Value
getConfig
          tempFile <- writeTempFile "/tmp" (execName <> "-" <> domain <> "-" <> ".yaml") (cs $ Yaml.encode config)
          (_, Just stdoutHdl, Just stderrHdl, ph) <- createProcess (proc exe ["-c", tempFile]) {cwd = cwd, std_out = CreatePipe, std_err = CreatePipe}
          let colorize = (String -> String) -> Maybe (String -> String) -> String -> String
forall a. a -> Maybe a -> a
fromMaybe String -> String
forall a. a -> a
id (String -> [(String, String -> String)] -> Maybe (String -> String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
execName [(String, String -> String)]
processColors)
          void $ forkIO $ logToConsoleDebug (Just stdOut) colorize prefix stdoutHdl
          void $ forkIO $ logToConsoleDebug (Just stdErr) colorize prefix stderrHdl
          liftIO $ writeIORef phRef (Just ph)
          pure $ ServiceInstance ph tempFile

  void $
    hoistCodensity $
      Codensity $
        E.bracket initProcess cleanupService

  lift $
    addFailureContext ("Waiting for service: " <> prefix) $ do
      waitUntilServiceIsUp (Just $ ProcessDebug {phRef = phRef, stdOut = stdOut, stdErr = stdErr}) domain service

logToConsole :: (String -> String) -> String -> Handle -> IO ()
logToConsole :: (String -> String) -> String -> Handle -> IO ()
logToConsole = Maybe (IORef [String])
-> (String -> String) -> String -> Handle -> IO ()
logToConsoleDebug Maybe (IORef [String])
forall a. Maybe a
Nothing

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

retryRequestUntil :: (HasCallStack) => ((HasCallStack) => App Bool) -> String -> App ()
retryRequestUntil :: HasCallStack => (HasCallStack => App Bool) -> String -> App ()
retryRequestUntil = HasCallStack =>
Maybe ProcessDebug
-> (HasCallStack => App Bool) -> String -> App ()
Maybe ProcessDebug
-> (HasCallStack => App Bool) -> String -> App ()
retryRequestUntilDebug Maybe ProcessDebug
forall a. Maybe a
Nothing

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

retryRequestUntilDebug :: (HasCallStack) => Maybe ProcessDebug -> ((HasCallStack) => App Bool) -> String -> App ()
retryRequestUntilDebug :: HasCallStack =>
Maybe ProcessDebug
-> (HasCallStack => App Bool) -> String -> App ()
retryRequestUntilDebug Maybe ProcessDebug
mProcessDebug HasCallStack => App Bool
reqAction String
err = do
  isUp <-
    RetryPolicyM App
-> (RetryStatus -> Bool -> App Bool)
-> (RetryStatus -> App Bool)
-> App Bool
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying
      (Int -> RetryPolicyM App -> RetryPolicyM App
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) (Int -> RetryPolicyM App
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
fibonacciBackoff (Int
200 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)))
      (\RetryStatus
_ Bool
isUp -> Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Bool
not Bool
isUp))
      (App Bool -> RetryStatus -> App Bool
forall a b. a -> b -> a
const App Bool
HasCallStack => App Bool
reqAction)
  unless isUp $ do
    case mProcessDebug of
      Maybe ProcessDebug
Nothing ->
        String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String
"Timed out waiting for service " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to come up")
      Just (ProcessDebug {IORef [String]
IORef (Maybe ProcessHandle)
phRef :: ProcessDebug -> IORef (Maybe ProcessHandle)
stdOut :: ProcessDebug -> IORef [String]
stdErr :: ProcessDebug -> IORef [String]
phRef :: IORef (Maybe ProcessHandle)
stdOut :: IORef [String]
stdErr :: IORef [String]
..}) -> do
        stdOut' <- IO [String] -> App [String]
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> App [String]) -> IO [String] -> App [String]
forall a b. (a -> b) -> a -> b
$ IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef IORef [String]
stdOut
        stdErr' <- liftIO $ readIORef stdErr
        mPh <- liftIO $ readIORef phRef
        let stdOutStr = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" [String]
stdOut'
            stdErrStr = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" [String]
stdErr'
        mExitCode <- maybe (pure Nothing) (liftIO . getProcessExitCode) mPh
        let msg =
              String
"Timed out waiting for service "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to come up\n"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"stdout:\n"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
stdOutStr
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nstderr:\n"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
stdErrStr
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nexitCode:\n"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show (String -> (ExitCode -> String) -> Maybe ExitCode -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"no exit code" ExitCode -> String
forall a. Show a => a -> String
show Maybe ExitCode
mExitCode)
        addFailureContext msg $
          assertFailure msg

startNginzK8s :: String -> ServiceMap -> IO ServiceInstance
startNginzK8s :: String -> ServiceMap -> IO ServiceInstance
startNginzK8s String
domain ServiceMap
sm = do
  tmpDir <- IO String -> IO String
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
createTempDirectory String
"/tmp" (String
"nginz" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
domain)
  liftIO $
    copyDirectoryRecursively "/etc/wire/nginz/" tmpDir

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

  Text.writeFile nginxConfFile $ replaceUpstreamsInConfig conf' sm

  ph <- startNginz domain nginxConfFile "/"
  pure $ ServiceInstance ph tmpDir

startNginzLocal :: BackendResource -> App ServiceInstance
startNginzLocal :: BackendResource -> App ServiceInstance
startNginzLocal BackendResource
resource = do
  let domain :: String
domain = BackendResource -> String
berDomain BackendResource
resource
  sm <- HasCallStack => String -> App ServiceMap
String -> App ServiceMap
getServiceMap String
domain

  -- 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 <- liftIO $ createTempDirectory "/tmp" ("nginz" <> "-" <> domain)
  mBaseDir <- asks (.servicesCwdBase)
  basedir <- maybe (failApp "service cwd base not found") pure mBaseDir

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

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

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

  liftIO $ do
    whenM (doesFileExist integrationConfFile) $ removeFile integrationConfFile
    writeFile integrationConfFile portConfig

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

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

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

  -- start service
  ph <- liftIO $ startNginz domain nginxConfFile tmpDir

  -- return handle and nginx tmp dir path
  pure $ ServiceInstance ph tmpDir

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

-- | replace 'upstream <name> { ... }' blocks
replaceUpstreamsInConfig :: Text.Text -> ServiceMap -> Text.Text
replaceUpstreamsInConfig :: Text -> ServiceMap -> Text
replaceUpstreamsInConfig Text
nginxConf ServiceMap
sm =
  Text -> Text -> Text
insertGeneratedUpstreams Text
generateUpstreamsText (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
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 :: Text
removeUpstreamBlocks =
      Text -> Matches Text -> Text
forall a. Replace a => a -> Matches a -> a
replaceAll Text
"" (Matches Text -> Text) -> Matches Text -> Text
forall a b. (a -> b) -> a -> b
$
        -- regex-tdfa does unfortunately not support shorthands for character classes.
        Text
nginxConf Text -> RE -> Matches Text
forall s. IsRegex RE s => s -> RE -> Matches s
*=~ [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 :: Text -> Text -> Text
insertGeneratedUpstreams Text
ups Text
conf =
      case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
"http {" Text
conf of
        (Text
pre, Text
rest)
          | Bool -> Bool
not (Text -> Bool
Text.null Text
rest) ->
              let (Text
httpOpen, Text
postOpen) = Int -> Text -> (Text, Text)
Text.splitAt (Text -> Int
Text.length Text
"http {") Text
rest
               in [Text] -> Text
Text.concat [Text
pre, Text
httpOpen, Text
"\n\n", Text
ups, Text
postOpen]
        (Text, Text)
_ -> [Text] -> Text
Text.concat [Text
ups, Text
"\n", Text
conf]

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

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

  let prefix = String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"nginz" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
domain String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] "
  let colorize = (String -> String) -> Maybe (String -> String) -> String -> String
forall a. a -> Maybe a -> a
fromMaybe String -> String
forall a. a -> a
id (String -> [(String, String -> String)] -> Maybe (String -> String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"nginx" [(String, String -> String)]
processColors)

  void $ forkIO $ logToConsole colorize prefix stdoutHdl
  void $ forkIO $ logToConsole colorize prefix stderrHdl

  pure ph