Merge branch 'adinapoli/issue-463' into 'dev'

Use Async.race in serverCLI start-all to fix initialisation bug

See merge request !404

bin/gargantext-cli/CLI/Server.hs

+{-# LANGUAGE TemplateHaskell #-}
 {-|
 Module      : CLI.Server
 Description : Gargantext Server
@@ -15,16 +16,18 @@ module CLI.Server where
 import CLI.Parsers (settings_p)
 import CLI.Types
 import CLI.Worker (runAllWorkers)
+import Control.Concurrent.Async qualified as Async
 import Control.Monad.IO.Class
+import Data.Text qualified as T
 import Data.Version (showVersion)
-import Gargantext.API.Admin.EnvTypes (Mode(..))
+import GHC.IO.Encoding (setLocaleEncoding, utf8)
 import Gargantext.API (startGargantext)
+import Gargantext.API.Admin.EnvTypes (Mode(..))
 import Gargantext.Core.Config
 import Gargantext.Core.Config.Types (_SettingsFile)
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Prelude
 import Gargantext.System.Logging
-import GHC.IO.Encoding (setLocaleEncoding, utf8)
 import Options.Applicative
 import Paths_gargantext qualified as PG -- cabal magic build module
 
@@ -41,8 +44,15 @@ serverCLI (CLIS_start serverArgs) = withServerCLILogger serverArgs $ \ioLogger -
 
 serverCLI (CLIS_startAll serverArgs@(ServerArgs { .. })) = withServerCLILogger serverArgs $ \ioLogger -> do
   withAsync (startServerCLI ioLogger serverArgs) $ \aServer -> do
-    runAllWorkers ioLogger server_toml
-    wait aServer
+    res <- Async.race (runAllWorkers ioLogger server_toml) (waitCatch aServer)
+    case res of
+      Left ()  -> pure ()
+      Right (Left ex)
+        -> do
+          $(logLoc) ioLogger ERROR $ "Exception raised when running the server:\n\n" <> T.pack (displayException ex)
+          exitFailure
+      Right (Right ())
+        -> pure ()
 
 serverCLI (CLIS_version) = withLogger (LogConfig Nothing DEBUG) $ \ioLogger -> do
     -- Sets the locale to avoid encoding issues like in #284.

bin/gargantext-cli/CLI/Worker.hs

@@ -126,6 +126,15 @@ stats_p = fmap CLIW_stats $ WorkerStatsArgs
   <$> settings_p
 
 
+-- | Runs all the workers concurrently.
+-- /NOTE/: Be very careful, this IS a BLOCKING operation, despite its usage
+-- of 'forConcurrently_' under the hood. In particular 'forConcurrently_' will
+-- execute the inner action in parallel discarding the results, but the inner
+-- action has still to terminate!
+-- That is /NOT/ the case for this function, which is meant to start the infinite
+-- loop for the workers, so beware when using this, make sure that the calling
+-- code is using this properly (for example along the use of 'race' or a similar
+-- function from async).
 runAllWorkers :: Logger IO -> SettingsFile -> IO ()
 runAllWorkers ioLogger worker_toml = do
   cfg <- readConfig worker_toml

src/Gargantext/API.hs

@@ -61,12 +61,10 @@ import Network.Wai (Middleware, Request, requestHeaders)
 import Network.Wai.Handler.Warp hiding (defaultSettings)
 import Network.Wai.Middleware.Cors
 import Network.Wai.Middleware.RequestLogger (logStdout)
--- import Paths_gargantext (getDataDir)
 import Servant hiding (Header)
 import Servant.Client.Core.BaseUrl (showBaseUrl)
 import System.Clock qualified as Clock
 import System.Cron.Schedule qualified as Cron
--- import System.FilePath
 
 -- | startGargantext takes as parameters port number and Toml file.
 startGargantext :: Mode -> PortNumber -> SettingsFile -> IO ()