{-# LANGUAGE OverloadedStrings #-}

module Testlib.ModService
  ( withModifiedBackend,
    startDynamicBackend,
    startDynamicBackends,
    traverseConcurrentlyCodensity,
  )
where

import Control.Concurrent
import Control.Concurrent.Async
import qualified Control.Exception as E
import Control.Monad.Catch (catch, displayException, throwM)
import Control.Monad.Codensity
import Control.Monad.Extra
import Control.Monad.Reader
import Control.Retry (fibonacciBackoff, limitRetriesByCumulativeDelay, retrying)
import Data.Aeson hiding ((.=))
import Data.Default
import Data.Foldable
import Data.Function
import Data.Functor
import Data.Maybe
import Data.Monoid
import Data.String
import Data.String.Conversions (cs)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Traversable
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.FilePath
import System.IO
import System.IO.Temp (createTempDirectory, writeTempFile)
import System.Posix (keyboardSignal, killProcess, signalProcess)
import System.Process
import Testlib.App
import Testlib.Assertions (prettierCallStack)
import Testlib.HTTP
import Testlib.JSON
import Testlib.Printing
import Testlib.ResourcePool
import Testlib.Types
import Text.RawString.QQ
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. [ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends [ServiceOverrides
overrides] (\[String]
domains -> HasCallStack => String -> App a
String -> App a
k ([String] -> String
forall a. HasCallStack => [a] -> a
head [String]
domains))

copyDirectoryRecursively :: FilePath -> FilePath -> IO ()
copyDirectoryRecursively :: String -> String -> IO ()
copyDirectoryRecursively String
from String
to = do
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
to
  [String]
files <- String -> IO [String]
listDirectory String
from
  [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
files ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
    Bool
isDirectory <- String -> IO Bool
doesDirectoryExist String
fromPath
    if Bool
isDirectory
      then String -> String -> IO ()
copyDirectoryRecursively String
fromPath String
toPath
      else String -> String -> IO ()
copyFile String
fromPath String
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.
  [(MVar (Maybe SomeException), MVar ())]
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
    MVar (Maybe SomeException)
result <- IO (MVar (Maybe SomeException))
forall a. IO (MVar a)
newEmptyMVar
    MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    (MVar (Maybe SomeException), MVar ())
-> IO (MVar (Maybe SomeException), MVar ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MVar (Maybe SomeException)
result, MVar ()
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.
  ((MVar (Maybe SomeException), MVar ()), a) -> IO ()
runAction <- App (((MVar (Maybe SomeException), MVar ()), a) -> IO ())
-> Codensity
     App (((MVar (Maybe SomeException), MVar ()), a) -> IO ())
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 (((MVar (Maybe SomeException), MVar ()), a) -> IO ())
 -> Codensity
      App (((MVar (Maybe SomeException), MVar ()), a) -> IO ()))
-> App (((MVar (Maybe SomeException), MVar ()), a) -> IO ())
-> Codensity
     App (((MVar (Maybe SomeException), MVar ()), a) -> IO ())
forall a b. (a -> b) -> a -> b
$ (((MVar (Maybe SomeException), MVar ()), a) -> App ())
-> App (((MVar (Maybe SomeException), MVar ()), a) -> IO ())
forall a b. (a -> App b) -> App (a -> IO b)
appToIOKleisli ((((MVar (Maybe SomeException), MVar ()), a) -> App ())
 -> App (((MVar (Maybe SomeException), MVar ()), a) -> IO ()))
-> (((MVar (Maybe SomeException), MVar ()), a) -> App ())
-> App (((MVar (Maybe SomeException), MVar ()), a) -> IO ())
forall a b. (a -> b) -> a -> b
$ \((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.
  [Async ()]
asyncs <- [((MVar (Maybe SomeException), MVar ()), a)]
-> (((MVar (Maybe SomeException), MVar ()), a)
    -> Codensity App (Async ()))
-> Codensity App [Async ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([(MVar (Maybe SomeException), MVar ())]
-> [a] -> [((MVar (Maybe SomeException), MVar ()), a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(MVar (Maybe SomeException), MVar ())]
vars [a]
args) ((((MVar (Maybe SomeException), MVar ()), a)
  -> Codensity App (Async ()))
 -> Codensity App [Async ()])
-> (((MVar (Maybe SomeException), MVar ()), a)
    -> Codensity App (Async ()))
-> Codensity App [Async ()]
forall a b. (a -> b) -> a -> b
$ \((MVar (Maybe SomeException), MVar ()), a)
x ->
    (forall b. (Async () -> App b) -> App b)
-> Codensity App (Async ())
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (Async () -> App b) -> App b)
 -> Codensity App (Async ()))
-> (forall b. (Async () -> App b) -> App b)
-> Codensity App (Async ())
forall a b. (a -> b) -> a -> b
$ \Async () -> App b
k -> do
      Async () -> IO b
k' <- (Async () -> App b) -> App (Async () -> IO b)
forall a b. (a -> App b) -> App (a -> IO b)
appToIOKleisli Async () -> App b
k
      IO b -> App b
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> App b) -> IO b -> App b
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) Async () -> IO b
k'

  -- Wait for all the threads set their result variables. Any exception is
  -- rethrown here, and aborts the overall function.
  IO () -> Codensity App ()
forall a. IO a -> Codensity App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Codensity App ()) -> IO () -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ [(MVar (Maybe SomeException), MVar ())]
-> ((MVar (Maybe SomeException), MVar ()) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(MVar (Maybe SomeException), MVar ())]
vars (((MVar (Maybe SomeException), MVar ()) -> IO ()) -> IO ())
-> ((MVar (Maybe SomeException), MVar ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(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

  (forall b. (() -> App b) -> App b) -> Codensity App ()
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (() -> App b) -> App b) -> Codensity App ())
-> (forall b. (() -> App b) -> App b) -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ \() -> App b
k -> do
    -- Now run the main continuation.
    b
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.
    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
$ ((MVar (Maybe SomeException), MVar ()) -> IO ())
-> [(MVar (Maybe SomeException), MVar ())] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(MVar (Maybe SomeException)
_, MVar ()
d) -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
d ()) [(MVar (Maybe SomeException), MVar ())]
vars
    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
$ (Async () -> IO ()) -> [Async ()] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Async () -> IO ()
forall a. Async a -> IO a
wait [Async ()]
asyncs

    b -> App b
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
result

startDynamicBackends :: [ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends :: forall a. [ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends [ServiceOverrides]
beOverrides [String] -> App a
k = do
  let startDynamicBackendsCodensity :: Codensity App [String]
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."
        ResourcePool BackendResource
pool <- (Env -> ResourcePool BackendResource)
-> Codensity App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.resourcePool)
        [BackendResource]
resources <- Int
-> ResourcePool BackendResource -> Codensity App [BackendResource]
forall (m :: * -> *) a.
(Ord a, MonadIO m, MonadMask m, HasCallStack) =>
Int -> ResourcePool a -> Codensity m [a]
acquireResources ([ServiceOverrides] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [ServiceOverrides]
beOverrides) ResourcePool BackendResource
pool
        Codensity App () -> Codensity App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Codensity App () -> Codensity App ())
-> Codensity App () -> Codensity App ()
forall a b. (a -> b) -> a -> b
$
          (HasCallStack =>
 (BackendResource, ServiceOverrides) -> Codensity App ())
-> HasCallStack =>
   [(BackendResource, ServiceOverrides)] -> Codensity App ()
forall a.
(HasCallStack => a -> Codensity App ())
-> HasCallStack => [a] -> Codensity App ()
traverseConcurrentlyCodensity
            (Codensity App String -> Codensity App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Codensity App String -> Codensity App ())
-> ((BackendResource, ServiceOverrides) -> Codensity App String)
-> (BackendResource, ServiceOverrides)
-> Codensity App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BackendResource -> ServiceOverrides -> Codensity App String)
-> (BackendResource, ServiceOverrides) -> Codensity App String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App String
BackendResource -> ServiceOverrides -> Codensity App String
startDynamicBackend)
            ([BackendResource]
-> [ServiceOverrides] -> [(BackendResource, ServiceOverrides)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BackendResource]
resources [ServiceOverrides]
beOverrides)
        [String] -> Codensity App [String]
forall a. a -> Codensity App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> Codensity App [String])
-> [String] -> Codensity App [String]
forall a b. (a -> b) -> a -> b
$ (BackendResource -> String) -> [BackendResource] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (.berDomain) [BackendResource]
resources
  Codensity App [String] -> forall b. ([String] -> App b) -> App b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity Codensity App [String]
startDynamicBackendsCodensity [String] -> 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
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 "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
        }

    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)
        }

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
        Value
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 (Service
srv, Service
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]

startBackend ::
  (HasCallStack) =>
  BackendResource ->
  ServiceOverrides ->
  Codensity App ()
startBackend :: HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App ()
startBackend BackendResource
resource ServiceOverrides
overrides = do
  (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

ensureBackendReachable :: (HasCallStack) => String -> App ()
ensureBackendReachable :: HasCallStack => String -> App ()
ensureBackendReachable String
domain = do
  Env
env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  let checkServiceIsUpReq :: (HasCallStack) => App Bool
      checkServiceIsUpReq :: HasCallStack => App Bool
checkServiceIsUpReq = do
        Request
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 [])
        IO Bool
checkStatus <- App Bool -> App (IO Bool)
forall a. App a -> App (IO a)
appToIO (App Bool -> App (IO Bool)) -> App Bool -> App (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
          Response
res <- String -> Request -> App Response
submit String
"POST" Request
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 :: Bool
is200 = Response
res.status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200
          Maybe Value
mInner <- App Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Response
res.json String
"inner"
          Bool
isFedDenied <- case Maybe Value
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
              String
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
              Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> App Bool) -> Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ Response
res.status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
533 Bool -> Bool -> Bool
&& String
label String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"federation-denied"

          Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
is200 Bool -> Bool -> Bool
|| Bool
isFedDenied)
        Either HttpException Bool
eith <- IO (Either HttpException Bool) -> App (Either HttpException Bool)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO (Either HttpException Bool)
forall e a. Exception e => IO a -> IO (Either e a)
E.try IO Bool
checkStatus)
        Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> App Bool) -> Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ (HttpException -> Bool)
-> (Bool -> Bool) -> Either HttpException Bool -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(HttpException
_e :: HTTP.HttpException) -> Bool
False) Bool -> Bool
forall a. a -> a
id Either HttpException Bool
eith

  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((String
domain String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= Env
env.domain1) Bool -> Bool -> Bool
&& (String
domain String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= Env
env.domain2)) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    HasCallStack => (HasCallStack => App Bool) -> String -> App ()
(HasCallStack => App Bool) -> String -> App ()
retryRequestUntil App Bool
HasCallStack => App Bool
checkServiceIsUpReq String
"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
  let ignoreExceptions :: (HasCallStack) => IO () -> IO ()
      ignoreExceptions :: HasCallStack => IO () -> IO ()
ignoreExceptions IO ()
action = IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch IO ()
action ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: E.SomeException) -> do
        String
callstackPretty <- CallStack -> IO String
prettierCallStack CallStack
HasCallStack => CallStack
callStack
        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
"Exception while cleaning up a service: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\ncallstack: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
callstackPretty
  HasCallStack => IO () -> IO ()
IO () -> IO ()
ignoreExceptions (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe Pid
mPid <- ProcessHandle -> IO (Maybe Pid)
getPid ServiceInstance
inst.handle
    Maybe Pid -> (Pid -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Pid
mPid (Signal -> Pid -> IO ()
signalProcess Signal
keyboardSignal)
    Int -> IO ExitCode -> IO (Maybe ExitCode)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
50000 (ProcessHandle -> IO ExitCode
waitForProcess ServiceInstance
inst.handle) IO (Maybe ExitCode) -> (Maybe ExitCode -> 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
>>= \case
      Just ExitCode
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Maybe ExitCode
Nothing -> do
        Maybe Pid -> (Pid -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Pid
mPid (Signal -> Pid -> 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
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
doesFileExist ServiceInstance
inst.config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile ServiceInstance
inst.config
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
doesDirectoryExist ServiceInstance
inst.config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive ServiceInstance
inst.config

-- | Wait for a service to come up.
waitUntilServiceIsUp :: (HasCallStack) => String -> Service -> App ()
waitUntilServiceIsUp :: HasCallStack => String -> Service -> App ()
waitUntilServiceIsUp String
domain Service
srv =
  HasCallStack => (HasCallStack => App Bool) -> String -> App ()
(HasCallStack => App Bool) -> String -> App ()
retryRequestUntil
    (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
  Request
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"
  IO Bool
checkStatus <- App Bool -> App (IO Bool)
forall a. App a -> App (IO a)
appToIO (App Bool -> App (IO Bool)) -> App Bool -> App (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
    Response
res <- String -> Request -> App Response
submit String
"GET" Request
req
    Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response
res.status Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
200, Int
204])
  Either HttpException Bool
eith <- IO (Either HttpException Bool) -> App (Either HttpException Bool)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO (Either HttpException Bool)
forall e a. Exception e => IO a -> IO (Either e a)
E.try IO Bool
checkStatus)
  Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> App Bool) -> Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ (HttpException -> Bool)
-> (Bool -> Bool) -> Either HttpException Bool -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(HttpException
_e :: HTTP.HttpException) -> Bool
False) Bool -> Bool
forall a. a -> a
id Either HttpException Bool
eith

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
  ServiceMap
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
  IO Value
getConfig <-
    App (IO Value) -> Codensity App (IO Value)
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 (IO Value) -> Codensity App (IO Value))
-> (App Value -> App (IO Value))
-> App Value
-> Codensity App (IO Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App Value -> App (IO Value)
forall a. App a -> App (IO a)
appToIO (App Value -> Codensity App (IO Value))
-> App Value -> Codensity 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
  let execName :: String
execName = Service -> String
configName Service
service
  (Maybe String
cwd, String
exe) <-
    App (Maybe String, String) -> Codensity App (Maybe String, String)
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 (Maybe String, String)
 -> Codensity App (Maybe String, String))
-> App (Maybe String, String)
-> Codensity App (Maybe String, String)
forall a b. (a -> b) -> a -> b
$ (Env -> (Maybe String, String)) -> App (Maybe String, String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks \Env
env -> case Env
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)

  IO ServiceInstance
startNginzLocalIO <- App (IO ServiceInstance) -> Codensity App (IO ServiceInstance)
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 (IO ServiceInstance) -> Codensity App (IO ServiceInstance))
-> App (IO ServiceInstance) -> Codensity App (IO ServiceInstance)
forall a b. (a -> b) -> a -> b
$ App ServiceInstance -> App (IO ServiceInstance)
forall a. App a -> App (IO a)
appToIO (App ServiceInstance -> App (IO ServiceInstance))
-> App ServiceInstance -> App (IO ServiceInstance)
forall a b. (a -> b) -> a -> b
$ BackendResource -> App ServiceInstance
startNginzLocal BackendResource
resource

  let initProcess :: IO ServiceInstance
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
          Value
config <- IO Value
getConfig
          String
tempFile <- String -> String -> String -> IO String
writeTempFile String
"/tmp" (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 -> String
forall a. Semigroup a => a -> a -> a
<> String
".yaml") (ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Value
config)
          (Maybe Handle
_, Just Handle
stdoutHdl, Just Handle
stderrHdl, ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
proc String
exe [String
"-c", String
tempFile]) {cwd = cwd, std_out = CreatePipe, std_err = CreatePipe}
          let prefix :: String
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
"] "
          let colorize :: String -> String
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)
          IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (String -> String) -> String -> Handle -> IO ()
logToConsole String -> String
colorize String
prefix Handle
stdoutHdl
          IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (String -> String) -> String -> Handle -> IO ()
logToConsole String -> String
colorize String
prefix Handle
stderrHdl
          ServiceInstance -> IO ServiceInstance
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServiceInstance -> IO ServiceInstance)
-> ServiceInstance -> IO ServiceInstance
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> String -> ServiceInstance
ServiceInstance ProcessHandle
ph String
tempFile

  Codensity App ServiceInstance -> Codensity App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Codensity App ServiceInstance -> Codensity App ())
-> Codensity App ServiceInstance -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ (forall b. (ServiceInstance -> App b) -> App b)
-> Codensity App ServiceInstance
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (ServiceInstance -> App b) -> App b)
 -> Codensity App ServiceInstance)
-> (forall b. (ServiceInstance -> App b) -> App b)
-> Codensity App ServiceInstance
forall a b. (a -> b) -> a -> b
$ \ServiceInstance -> App b
k -> do
    ServiceInstance -> IO b
iok <- (ServiceInstance -> App b) -> App (ServiceInstance -> IO b)
forall a b. (a -> App b) -> App (a -> IO b)
appToIOKleisli ServiceInstance -> App b
k
    IO b -> App b
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> App b) -> IO b -> App b
forall a b. (a -> b) -> a -> b
$ IO ServiceInstance
-> (ServiceInstance -> IO ()) -> (ServiceInstance -> IO b) -> IO b
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO ServiceInstance
initProcess HasCallStack => ServiceInstance -> IO ()
ServiceInstance -> IO ()
cleanupService ServiceInstance -> IO b
iok

  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 -> Service -> App ()
String -> Service -> App ()
waitUntilServiceIsUp String
domain Service
service

logToConsole :: (String -> String) -> String -> Handle -> IO ()
logToConsole :: (String -> String) -> String -> Handle -> IO ()
logToConsole String -> String
colorize String
prefix Handle
hdl = do
  let go :: IO ()
go =
        do
          String
line <- Handle -> IO String
hGetLine Handle
hdl
          String -> IO ()
putStrLn (String -> String
colorize (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
line))
          IO ()
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 => App Bool
reqAction String
err = do
  Bool
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)
  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isUp (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$
    String -> App ()
forall a. HasCallStack => String -> App a
failApp (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")

startNginzK8s :: String -> ServiceMap -> IO ServiceInstance
startNginzK8s :: String -> ServiceMap -> IO ServiceInstance
startNginzK8s String
domain ServiceMap
sm = do
  String
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)
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> String -> IO ()
copyDirectoryRecursively String
"/etc/wire/nginz/" String
tmpDir

  let nginxConfFile :: String
nginxConfFile = String
tmpDir String -> String -> String
</> String
"conf" String -> String -> String
</> String
"nginx.conf"
      upstreamsCfg :: String
upstreamsCfg = String
tmpDir String -> String -> String
</> String
"upstreams.conf"
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text
conf <- String -> IO Text
Text.readFile String
nginxConfFile
    String -> Text -> IO ()
Text.writeFile String
nginxConfFile (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
      ( 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"
          -- TODO: 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 -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace (Text
"/etc/wire/nginz/upstreams/upstreams.conf") (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
upstreamsCfg)
      )
  String -> ServiceMap -> IO ()
createUpstreamsCfg String
upstreamsCfg ServiceMap
sm
  ProcessHandle
ph <- String -> String -> String -> IO ProcessHandle
startNginz String
domain String
nginxConfFile String
"/"
  ServiceInstance -> IO ServiceInstance
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServiceInstance -> IO ServiceInstance)
-> ServiceInstance -> IO ServiceInstance
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> String -> ServiceInstance
ServiceInstance ProcessHandle
ph String
tmpDir

startNginzLocal :: BackendResource -> App ServiceInstance
startNginzLocal :: BackendResource -> App ServiceInstance
startNginzLocal BackendResource
resource = do
  let domain :: String
domain = BackendResource -> String
berDomain BackendResource
resource
      http2Port :: Word16
http2Port = BackendResource -> Word16
berNginzHttp2Port BackendResource
resource
      sslPort :: Word16
sslPort = BackendResource -> Word16
berNginzSslPort BackendResource
resource
  ServiceMap
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.
  String
tmpDir <- 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
$ 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)
  Maybe String
mBaseDir <- (Env -> Maybe String) -> App (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.servicesCwdBase)
  String
basedir <- App String -> (String -> App String) -> Maybe String -> App String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> App String
forall a. HasCallStack => String -> App a
failApp String
"service cwd base not found") String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
mBaseDir

  -- copy all config files into the tmp dir
  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
    let from :: String
from = String
basedir String -> String -> String
</> String
"nginz" String -> String -> String
</> String
"integration-test"
    String -> String -> IO ()
copyDirectoryRecursively (String
from String -> String -> String
</> String
"conf" String -> String -> String
</> String
"nginz") (String
tmpDir String -> String -> String
</> String
"conf" String -> String -> String
</> String
"nginz")
    String -> String -> IO ()
copyDirectoryRecursively (String
from String -> String -> String
</> String
"resources") (String
tmpDir String -> String -> String
</> String
"resources")

  let integrationConfFile :: String
integrationConfFile = String
tmpDir String -> String -> String
</> String
"conf" String -> String -> String
</> String
"nginz" String -> String -> String
</> String
"integration.conf"

  -- hide access log
  let nginxConfFile :: String
nginxConfFile = String
tmpDir String -> String -> String
</> String
"conf" String -> String -> String
</> String
"nginz" String -> String -> String
</> String
"nginx.conf"
  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
    Text
conf <- String -> IO Text
Text.readFile String
nginxConfFile
    String -> Text -> IO ()
Text.writeFile String
nginxConfFile (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
      ( 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"
      )

  -- override port configuration
  let portConfigTemplate :: Text
portConfigTemplate =
        Text
[r|listen {localPort};
listen {http2_port};
listen {ssl_port} ssl;
listen [::]:{ssl_port} ssl;
http2 on;
|]
  let portConfig :: Text
portConfig =
        Text
portConfigTemplate
          Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"{localPort}" (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show (ServiceMap
sm.nginz.port))
          Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"{http2_port}" (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show Word16
http2Port)
          Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"{ssl_port}" (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show Word16
sslPort)

  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
$ IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
doesFileExist String
integrationConfFile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
integrationConfFile
  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 -> String -> IO ()
writeFile String
integrationConfFile (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
portConfig)

  -- override upstreams
  let upstreamsCfg :: String
upstreamsCfg = String
tmpDir String -> String -> String
</> String
"conf" String -> String -> String
</> String
"nginz" String -> String -> String
</> String
"upstreams"
  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 -> ServiceMap -> IO ()
createUpstreamsCfg String
upstreamsCfg ServiceMap
sm
  let upstreamFederatorTemplate :: Text
upstreamFederatorTemplate =
        Text
[r|upstream {name} {
server 127.0.0.1:{port} max_fails=3 weight=1;
}|]
  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 -> String -> IO ()
appendFile
      String
upstreamsCfg
      ( Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
          Text
upstreamFederatorTemplate
            Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"{name}" Text
"federator_external"
            Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"{port}" (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show ServiceMap
sm.federatorExternal.port)
      )

  -- override pid configuration
  let pidConfigFile :: String
pidConfigFile = String
tmpDir String -> String -> String
</> String
"conf" String -> String -> String
</> String
"nginz" String -> String -> String
</> String
"pid.conf"
  let pid :: String
pid = String
tmpDir String -> String -> String
</> String
"conf" String -> String -> String
</> String
"nginz" String -> String -> String
</> String
"nginz.pid"
  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
    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
doesFileExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String
pidConfigFile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
pidConfigFile
    String -> String -> IO ()
writeFile String
pidConfigFile (String -> String
forall a b. ConvertibleStrings a b => a -> b
cs (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"pid " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pid String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
";")

  -- start service
  ProcessHandle
ph <- IO ProcessHandle -> App ProcessHandle
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessHandle -> App ProcessHandle)
-> IO ProcessHandle -> App ProcessHandle
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> IO ProcessHandle
startNginz String
domain String
nginxConfFile String
tmpDir

  -- return handle and nginx tmp dir path
  ServiceInstance -> App ServiceInstance
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServiceInstance -> App ServiceInstance)
-> ServiceInstance -> App ServiceInstance
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> String -> ServiceInstance
ServiceInstance ProcessHandle
ph String
tmpDir

createUpstreamsCfg :: String -> ServiceMap -> IO ()
createUpstreamsCfg :: String -> ServiceMap -> IO ()
createUpstreamsCfg String
upstreamsCfg ServiceMap
sm = do
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
doesFileExist String
upstreamsCfg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
upstreamsCfg
  let upstreamTemplate :: Text
upstreamTemplate =
        Text
[r|upstream {name} {
least_conn;
keepalive 32;
server 127.0.0.1:{port} max_fails=3 weight=1;
}
|]

  [(String, Word16)] -> ((String, Word16) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
    [ (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
Spar, ServiceMap
sm.spar.port),
      (String
"proxy", ServiceMap
sm.proxy.port)
    ]
    \case
      (String
srv, Word16
p) -> do
        let upstream :: Text
upstream =
              Text
upstreamTemplate
                Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"{name}" (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
srv)
                Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"{port}" (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show Word16
p)
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
appendFile String
upstreamsCfg (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
upstream)

startNginz :: String -> FilePath -> FilePath -> IO ProcessHandle
startNginz :: String -> String -> String -> IO ProcessHandle
startNginz String
domain String
conf String
workingDir = do
  (Maybe Handle
_, Just Handle
stdoutHdl, Just Handle
stderrHdl, ProcessHandle
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
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
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)
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (String -> String) -> String -> Handle -> IO ()
logToConsole String -> String
colorize String
prefix Handle
stdoutHdl
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (String -> String) -> String -> Handle -> IO ()
logToConsole String -> String
colorize String
prefix Handle
stderrHdl

  ProcessHandle -> IO ProcessHandle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessHandle
ph