{-# LANGUAGE OverloadedStrings #-}

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

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 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 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 System.Posix (keyboardSignal, killProcess, signalProcess)
import System.Posix.Types
import System.Process
import Testlib.App
import Testlib.HTTP
import Testlib.JSON
import Testlib.Printing
import Testlib.ResourcePool
import Testlib.Types
import Text.RawString.QQ
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. [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
  [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
  [ServiceOverrides] -> ([BackendResource] -> App a) -> App a
forall a.
[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 :: [ServiceOverrides] -> ([BackendResource] -> App a) -> App a
startDynamicBackendsReturnResources :: forall a.
[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."
        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)
        [BackendResource] -> Codensity App [BackendResource]
forall a. a -> Codensity App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [BackendResource]
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
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
  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
$ BackendResource -> App ()
ensureFederatorPortIsFree 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

-- | Using ss because it is most convenient. Checking if a port is free in Haskell involves binding to it which is not what we want.
ensureFederatorPortIsFree :: BackendResource -> App ()
ensureFederatorPortIsFree :: BackendResource -> App ()
ensureFederatorPortIsFree BackendResource
resource = do
  ServiceMap
serviceMap <- HasCallStack => String -> App ServiceMap
String -> App ServiceMap
getServiceMap BackendResource
resource.berDomain
  let Word16
federatorExternalPort :: Word16 = ServiceMap
serviceMap.federatorExternal.port
  Env
env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  Int -> App () -> App (Maybe ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
UnliftIO.timeout (Env
env.timeOutSeconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000) (Word16 -> App ()
check Word16
federatorExternalPort) App (Maybe ()) -> (Maybe () -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word16 -> String
forall a. Show a => a -> String
show Word16
federatorExternalPort
    Just ()
_ -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    check :: Word16 -> App ()
    check :: Word16 -> App ()
check Word16
federatorExternalPort = do
      Env
env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
      let process :: CreateProcess
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
federatorExternalPort, String
"-s", String
"TCP:LISTEN"]) {std_out = CreatePipe, std_err = CreatePipe}
      (Maybe Handle
_, Just Handle
stdoutHdl, Just Handle
stderrHdl, ProcessHandle
ph) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> App (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> App (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> App (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
process
      let prefix :: String
prefix = String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"lsof" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BackendResource
resource.berDomain 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
":" <>) Env
env.currentTestName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] "
      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 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
forall a. a -> a
id String
prefix Handle
stderrHdl
      ExitCode
exitCode <- IO ExitCode -> App ExitCode
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> App ExitCode) -> IO ExitCode -> App ExitCode
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
      case ExitCode
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 federator port is free"
        ExitCode
ExitSuccess -> do
          String
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 String -> Either String [(ProcessID, String)]
parseLsof (String -> String
forall a. IsString a => String -> a
fromString String
lsofOutput) of
            Right ((ProcessID
processId, String
processName) : [(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
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Found a process listening on port: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word16 -> String
forall a. Show a => a -> String
show Word16
federatorExternalPort String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", killing the process: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
processName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", pid: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ProcessID -> String
forall a. Show a => a -> String
show ProcessID
processId
              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
$ Signal -> ProcessID -> IO ()
signalProcess Signal
killProcess ProcessID
processId
              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
$ Int -> IO ()
threadDelay Int
100_000
              Word16 -> App ()
check Word16
federatorExternalPort
            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
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> 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

-- | 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 Text (ProcessID, String)
-> Parser Text Char -> Parser [(ProcessID, String)]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
Parser.sepBy Parser Text (ProcessID, String)
lsofParser (Char -> Parser Text Char
Parser.char Char
'\n')) 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 Text (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 Text (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'))

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
  Maybe ProcessID
mPid <- ProcessHandle -> IO (Maybe ProcessID)
getPid ServiceInstance
inst.handle
  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
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 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
  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
  Env
env <- App Env -> Codensity App Env
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 Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  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
  let (Maybe String
cwd, String
exe) = 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 -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
":" <>) Env
env.currentTestName 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