Revert "integration: Fail with logs when a service times out to come …

…up (#3929)" (#3979)

This reverts commit 1f9f164.

integration/default.nix

@@ -38,7 +38,6 @@
 , lens
 , lens-aeson
 , lib
-, lifted-base
 , memory
 , mime
 , monad-control
@@ -63,7 +62,6 @@
 , temporary
 , text
 , time
-, timestats
 , transformers
 , transformers-base
 , unix
@@ -125,7 +123,6 @@ mkDerivation {
     kan-extensions
     lens
     lens-aeson
-    lifted-base
     memory
     mime
     monad-control
@@ -150,7 +147,6 @@ mkDerivation {
     temporary
     text
     time
-    timestats
     transformers
     transformers-base
     unix

integration/integration.cabal

@@ -152,7 +152,6 @@ library
     Testlib.Mock
     Testlib.MockIntegrationService
     Testlib.ModService
-    Testlib.ModService.ServiceInstance
     Testlib.One2One
     Testlib.Options
     Testlib.Ports
@@ -198,7 +197,6 @@ library
     , kan-extensions
     , lens
     , lens-aeson
-    , lifted-base
     , memory
     , mime
     , monad-control
@@ -223,7 +221,6 @@ library
     , temporary
     , text
     , time
-    , timestats
     , transformers
     , transformers-base
     , unix

integration/test/Test/Cargohold/API.hs

@@ -236,7 +236,7 @@ testDownloadURLOverride = do
     downloadURLRes.status `shouldMatchInt` 302
     cs @_ @String downloadURLRes.body `shouldMatch` ""
     downloadURL <- parseUrlThrow (C8.unpack (getHeader' (mk $ cs "Location") downloadURLRes))
-    cs @_ @String (HTTP.host downloadURL) `shouldMatch` downloadEndpoint
+    downloadEndpoint `shouldMatch` cs @_ @String (HTTP.host downloadURL)
     HTTP.port downloadURL `shouldMatchInt` 443
     True `shouldMatch` (HTTP.secure downloadURL)
 

integration/test/Test/Demo.hs

@@ -7,15 +7,10 @@ import qualified API.Brig as BrigP
 import qualified API.BrigInternal as BrigI
 import qualified API.GalleyInternal as GalleyI
 import qualified API.Nginz as Nginz
-import Control.Concurrent
 import Control.Monad.Cont
-import Data.Function
-import Data.Maybe
 import GHC.Stack
 import SetupHelpers
-import Testlib.ModService.ServiceInstance
 import Testlib.Prelude
-import UnliftIO.Directory
 
 -- | Deleting unknown clients should fail with 404.
 testDeleteUnknownClient :: HasCallStack => App ()
@@ -212,38 +207,3 @@ testFedV0Federation = do
 
   bob' <- BrigP.getUser alice bob >>= getJSON 200
   bob' %. "qualified_id" `shouldMatch` (bob %. "qualified_id")
-
-testServiceHandles :: App ()
-testServiceHandles = do
-  -- The name was generated with a roll of a fair dice
-  let exe = "/tmp/tmp-42956614-e50a-11ee-8c4b-6b596d54b36b"
-      execName = "test-exec"
-      dom = "test-domain"
-
-  writeFile
-    exe
-    "#!/usr/bin/env bash\n\
-    \echo errmsg >&2\n\
-    \for i in `seq 0 100`; do\n\
-    \  echo $i\n\
-    \  sleep 0.1\n\
-    \done\n"
-  perms <- getPermissions exe
-  setPermissions exe (setOwnerExecutable True perms)
-  serviceInstance <- liftIO $ startServiceInstance exe [] Nothing exe execName dom
-  liftIO $ threadDelay 1_000_000
-  cleanupServiceInstance serviceInstance
-  processState <- liftIO $ flushServiceInstanceOutput serviceInstance
-  processState
-    `shouldContainString` "=== stdout: ============================================\n\
-                          \[test-exec@test-domain] 0\n\
-                          \[test-exec@test-domain] 1\n\
-                          \[test-exec@test-domain] 2\n\
-                          \[test-exec@test-domain] 3\n\
-                          \[test-exec@test-domain] 4\n\
-                          \[test-exec@test-domain] 5\n\
-                          \[test-exec@test-domain] 6\n\
-                          \[test-exec@test-domain] 7\n"
-  processState
-    `shouldContainString` "=== stderr: ============================================\n\
-                          \[test-exec@test-domain] errmsg\n"

integration/test/Testlib/ModService.hs

@@ -29,25 +29,25 @@ import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
 import Data.Traversable
 import qualified Data.Yaml as Yaml
-import Debug.TimeStats (measureM)
 import GHC.Stack
 import qualified Network.HTTP.Client as HTTP
-import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeFile)
+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.HTTP
 import Testlib.JSON
-import Testlib.ModService.ServiceInstance
+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 overrides k = measureM "withModifiedBackend" $ do
+withModifiedBackend overrides k =
   startDynamicBackends [overrides] (\domains -> k (head domains))
 
 copyDirectoryRecursively :: FilePath -> FilePath -> IO ()
@@ -118,7 +118,7 @@ traverseConcurrentlyCodensity f args = do
     pure result
 
 startDynamicBackends :: [ServiceOverrides] -> ([String] -> App a) -> App a
-startDynamicBackends beOverrides k = measureM "startDynamicBackends" do
+startDynamicBackends beOverrides k =
   runCodensity
     do
       when (Prelude.length beOverrides > 3) $ lift $ failApp "Too many backends. Currently only 3 are supported."
@@ -203,22 +203,17 @@ startDynamicBackend resource beOverrides = do
     setLogLevel :: ServiceOverrides
     setLogLevel =
       def
-        { -- NOTE: if you want to set logLevel to "Debug", consider doing it for the service
-          -- you're interested in only.  it's *very* noisy!
-          sparCfg = setField "saml.logLevel" logLevel,
-          brigCfg = setField "logLevel" logLevel,
-          cannonCfg = setField "logLevel" logLevel,
-          cargoholdCfg = setField "logLevel" logLevel,
-          galleyCfg = setField "logLevel" logLevel,
-          gundeckCfg = setField "logLevel" logLevel,
-          nginzCfg = setField "logLevel" logLevel,
-          backgroundWorkerCfg = setField "logLevel" logLevel,
-          sternCfg = setField "logLevel" logLevel,
-          federatorInternalCfg = setField "logLevel" logLevel
+        { 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)
         }
-      where
-        logLevel :: String
-        logLevel = "Warn"
 
 updateServiceMapInConfig :: BackendResource -> Service -> Value -> App Value
 updateServiceMapInConfig resource forSrv config =
@@ -251,12 +246,12 @@ startBackend ::
   BackendResource ->
   ServiceOverrides ->
   Codensity App ()
-startBackend resource overrides = measureM "startBackend" do
+startBackend resource overrides = do
   traverseConcurrentlyCodensity (withProcess resource overrides) allServices
   lift $ ensureBackendReachable resource.berDomain
 
 ensureBackendReachable :: String -> App ()
-ensureBackendReachable domain = measureM "ensureBackendReachable" do
+ensureBackendReachable domain = do
   env <- ask
   let checkServiceIsUpReq = do
         req <-
@@ -285,21 +280,54 @@ ensureBackendReachable domain = measureM "ensureBackendReachable" do
         pure $ either (\(_e :: HTTP.HttpException) -> False) id eith
 
   when ((domain /= env.domain1) && (domain /= env.domain2)) $ do
-    retryRequestUntil checkServiceIsUpReq "Federator ingress" domain Nothing
+    retryRequestUntil checkServiceIsUpReq "Federator ingress"
+
+processColors :: [(String, String -> String)]
+processColors =
+  [ ("brig", colored green),
+    ("galley", colored yellow),
+    ("gundeck", colored blue),
+    ("cannon", colored orange),
+    ("cargohold", colored purpleish),
+    ("spar", colored orange),
+    ("federator", colored blue),
+    ("background-worker", colored blue),
+    ("nginx", colored purpleish)
+  ]
+
+data ServiceInstance = ServiceInstance
+  { handle :: ProcessHandle,
+    config :: FilePath
+  }
+
+timeout :: Int -> IO a -> IO (Maybe a)
+timeout usecs action = either (const Nothing) Just <$> race (threadDelay usecs) action
+
+cleanupService :: ServiceInstance -> IO ()
+cleanupService inst = do
+  let ignoreExceptions action = E.catch action $ \(_ :: E.SomeException) -> pure ()
+  ignoreExceptions $ do
+    mPid <- getPid inst.handle
+    for_ mPid (signalProcess keyboardSignal)
+    timeout 50000 (waitForProcess inst.handle) >>= \case
+      Just _ -> pure ()
+      Nothing -> do
+        for_ mPid (signalProcess killProcess)
+        void $ waitForProcess inst.handle
+  whenM (doesFileExist inst.config) $ removeFile inst.config
+  whenM (doesDirectoryExist inst.config) $ removeDirectoryRecursive inst.config
 
 -- | Wait for a service to come up.
-waitUntilServiceIsUp :: String -> Service -> ServiceInstance -> App ()
-waitUntilServiceIsUp domain srv serviceInstance = measureM "waitUntilServiceUp" do
+waitUntilServiceIsUp :: String -> Service -> App ()
+waitUntilServiceIsUp domain srv =
   retryRequestUntil
     (checkServiceIsUp domain srv)
     (show srv)
-    domain
-    (Just serviceInstance)
 
 -- | Check if a service is up and running.
 checkServiceIsUp :: String -> Service -> App Bool
 checkServiceIsUp _ Nginz = pure True
-checkServiceIsUp domain srv = measureM "checkServiceIsUp" do
+checkServiceIsUp domain srv = do
   req <- baseRequest domain srv Unversioned "/i/status"
   checkStatus <- appToIO $ do
     res <- submit "GET" req
@@ -325,34 +353,44 @@ withProcess resource overrides service = do
 
   startNginzLocalIO <- lift $ appToIO $ startNginzLocal resource
 
-  let initProcess = liftIO $ case (service, cwd) of
+  let initProcess = case (service, cwd) of
         (Nginz, Nothing) -> startNginzK8s domain sm
         (Nginz, Just _) -> startNginzLocalIO
         _ -> do
           config <- getConfig
           tempFile <- writeTempFile "/tmp" (execName <> "-" <> domain <> "-" <> ".yaml") (cs $ Yaml.encode config)
-          startServiceInstance exe ["-c", tempFile] cwd tempFile execName domain
+          (_, Just stdoutHdl, Just stderrHdl, ph) <- createProcess (proc exe ["-c", tempFile]) {cwd = cwd, std_out = CreatePipe, std_err = CreatePipe}
+          let prefix = "[" <> execName <> "@" <> domain <> "] "
+          let colorize = fromMaybe id (lookup execName processColors)
+          void $ forkIO $ logToConsole colorize prefix stdoutHdl
+          void $ forkIO $ logToConsole colorize prefix stderrHdl
+          pure $ ServiceInstance ph tempFile
 
   void $ Codensity $ \k -> do
-    UnliftIO.bracket initProcess cleanupServiceInstance $ \serviceInstance -> do
-      waitUntilServiceIsUp domain service serviceInstance
-      k serviceInstance
-
-retryRequestUntil :: HasCallStack => App Bool -> String -> String -> Maybe ServiceInstance -> App ()
-retryRequestUntil reqAction execName domain mServiceInstance = measureM "retryRequestUntil" do
+    iok <- appToIOKleisli k
+    liftIO $ E.bracket initProcess cleanupService iok
+
+  lift $ waitUntilServiceIsUp domain service
+
+logToConsole :: (String -> String) -> String -> Handle -> IO ()
+logToConsole colorize prefix hdl = do
+  let go =
+        do
+          line <- hGetLine hdl
+          putStrLn (colorize (prefix <> line))
+          go
+          `E.catch` (\(_ :: E.IOException) -> pure ())
+  go
+
+retryRequestUntil :: HasCallStack => App Bool -> String -> App ()
+retryRequestUntil reqAction err = do
   isUp <-
     retrying
       (limitRetriesByCumulativeDelay (4 * 1000 * 1000) (fibonacciBackoff (200 * 1000)))
       (\_ isUp -> pure (not isUp))
       (const reqAction)
-  unless isUp $ do
-    errDetails <- liftIO $ do
-      case mServiceInstance of
-        Nothing -> pure ""
-        Just serviceInstance -> do
-          outStr <- flushServiceInstanceOutput serviceInstance
-          pure $ unlines [":", outStr]
-    failApp ("Timed out waiting for service " <> execName <> "@" <> domain <> " to come up" <> errDetails)
+  unless isUp $
+    failApp ("Timed out waiting for service " <> err <> " to come up")
 
 startNginzK8s :: String -> ServiceMap -> IO ServiceInstance
 startNginzK8s domain sm = do
@@ -374,7 +412,8 @@ startNginzK8s domain sm = do
           & Text.replace ("/etc/wire/nginz/upstreams/upstreams.conf") (cs upstreamsCfg)
       )
   createUpstreamsCfg upstreamsCfg sm
-  startNginz domain nginxConfFile tmpDir
+  ph <- startNginz domain nginxConfFile "/"
+  pure $ ServiceInstance ph tmpDir
 
 startNginzLocal :: BackendResource -> App ServiceInstance
 startNginzLocal resource = do
@@ -447,7 +486,10 @@ server 127.0.0.1:{port} max_fails=3 weight=1;
     writeFile pidConfigFile (cs $ "pid " <> pid <> ";")
 
   -- start service
-  liftIO $ startNginz domain nginxConfFile tmpDir
+  ph <- liftIO $ startNginz domain nginxConfFile tmpDir
+
+  -- return handle and nginx tmp dir path
+  pure $ ServiceInstance ph tmpDir
 
 createUpstreamsCfg :: String -> ServiceMap -> IO ()
 createUpstreamsCfg upstreamsCfg sm = do
@@ -478,12 +520,19 @@ server 127.0.0.1:{port} max_fails=3 weight=1;
                 & Text.replace "{port}" (cs $ show p)
         liftIO $ appendFile upstreamsCfg (cs upstream)
 
-startNginz :: String -> FilePath -> FilePath -> IO ServiceInstance
-startNginz domain conf configDir = do
-  startServiceInstance
-    "nginx"
-    ["-c", conf, "-g", "daemon off;", "-e", "/dev/stdout"]
-    (Just configDir)
-    configDir
-    "nginz"
-    domain
+startNginz :: String -> FilePath -> FilePath -> IO ProcessHandle
+startNginz domain conf workingDir = do
+  (_, Just stdoutHdl, Just stderrHdl, ph) <-
+    createProcess
+      (proc "nginx" ["-c", conf, "-g", "daemon off;", "-e", "/dev/stdout"])
+        { cwd = Just workingDir,
+          std_out = CreatePipe,
+          std_err = CreatePipe
+        }
+
+  let prefix = "[" <> "nginz" <> "@" <> domain <> "] "
+  let colorize = fromMaybe id (lookup "nginx" processColors)
+  void $ forkIO $ logToConsole colorize prefix stdoutHdl
+  void $ forkIO $ logToConsole colorize prefix stderrHdl
+
+  pure ph