Commit d4dca13d authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

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

This commit uses the `race` function from the async library to fix a bug
where exceptions raised from the server async wouldn't be caught by the
top-level code.

The bug was stemming from the fact that `runAllWorkers` is **blocking**,
despite its usage of `forConcurrently_`. Therefore we were never
actually running the `wait` function below, but rather we were hanging
waiting on the result of the first function.

As a result the server could die but the workers could keep the main
thread alive, causing the bug we just saw as part of #463.
parent 4d964e3e
Pipeline #7532 passed with stages
in 44 minutes and 16 seconds
{-# 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.
......
......@@ -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 ()
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment