[log] try to use log file setting from .toml

This however throws 'resource busy' on 'openFile'.

bin/gargantext-cli/CLI/Server.hs

@@ -24,7 +24,7 @@ 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.Types (_SettingsFile)
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Prelude
 import Gargantext.System.Logging
@@ -39,25 +39,26 @@ withServerCLILogger ServerArgs{..} f = do
   withLogger (cfg ^. gc_logging) $ \logger -> f logger
 
 serverCLI :: CLIServer -> IO ()
-serverCLI (CLIS_start serverArgs) = withServerCLILogger serverArgs $ \ioLogger ->
-  startServerCLI ioLogger serverArgs
+serverCLI (CLIS_start serverArgs) = startServerCLI serverArgs
 
-serverCLI (CLIS_startAll serverArgs@(ServerArgs { .. })) = withServerCLILogger serverArgs $ \ioLogger -> do
-  withAsync (startServerCLI ioLogger serverArgs) $ \aServer -> do
-    res <- Async.race (runAllWorkers ioLogger server_toml) (waitCatch aServer)
+serverCLI (CLIS_startAll serverArgs@(ServerArgs { .. })) = do
+  withAsync (startServerCLI serverArgs) $ \aServer -> do
+    res <- Async.race (runAllWorkers 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
+          panicTrace $ "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
+serverCLI (CLIS_version) = withLogger dummyLogConfig $ \ioLogger -> do
     -- Sets the locale to avoid encoding issues like in #284.
   setLocaleEncoding utf8
   logMsg ioLogger INFO $ "Version: " <> showVersion PG.version
+  where
+    dummyLogConfig = LogConfig { _lc_log_file = Nothing, _lc_log_level = DEBUG}
 
 
 serverCmd :: HasCallStack => Mod CommandFields CLI
@@ -104,14 +105,15 @@ version_p :: Parser CLIServer
 version_p = pure CLIS_version
 
 
-startServerCLI :: Logger IO -> ServerArgs -> IO ()
-startServerCLI ioLogger (ServerArgs { .. }) = do
-  logMsg ioLogger INFO $ "starting server, mode: " <> show server_mode <> ", port: " <> show server_port <> ", config: " <> _SettingsFile server_toml
+startServerCLI :: ServerArgs -> IO ()
+startServerCLI (ServerArgs { .. }) = do
+  -- logMsg ioLogger INFO $ "starting server, mode: " <> show server_mode <> ", port: " <> show server_port <> ", config: " <> _SettingsFile server_toml
   -- Sets the locale to avoid encoding issues like in #284.
   setLocaleEncoding utf8
 
   when (server_mode == Mock) $ do
-    logMsg ioLogger ERROR "Mock mode not supported!"
-    exitFailure
+    -- logMsg ioLogger ERROR "Mock mode not supported!"
+    panicTrace "Mock mode not supported!"
+    -- exitFailure
 
   startGargantext server_mode server_port server_toml

bin/gargantext-cli/CLI/Worker.hs

@@ -17,20 +17,18 @@ import Async.Worker.Types qualified as W
 import CLI.Types
 import CLI.Parsers
 import Control.Concurrent.Async (forConcurrently_)
-import Data.List qualified as List (cycle, concat, take)
 import Data.Text qualified as T
-import Gargantext.Core.Config (hasConfig, gc_worker, gc_logging)
+import Gargantext.Core.Config (hasConfig, gc_worker)
 import Gargantext.Core.Config.Types (SettingsFile(..))
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Config.Worker (WorkerDefinition(..), WorkerSettings(..), findDefinitionByName)
 import Gargantext.Core.Worker (withPGMQWorkerCtrlC, withPGMQWorkerSingleCtrlC, initWorkerState)
-import Gargantext.Core.Worker.Env (withWorkerEnv)
+import Gargantext.Core.Worker.Env (withWorkerEnv, runWorkerMonad)
 -- import Gargantext.Core.Worker.Jobs (sendJob)
 -- import Gargantext.Core.Worker.Jobs.Types (Job(Ping))
 import Gargantext.Prelude
-import Gargantext.System.Logging (withLogger, logMsg, LogLevel(..), Logger)
+import Gargantext.System.Logging (logM, LogLevel(..))
 import Options.Applicative
-import Prelude qualified
 
 
 -- TODO Command to monitor queues
@@ -38,60 +36,48 @@ import Prelude qualified
 
 workerCLI :: CLIWorker -> IO ()
 workerCLI (CLIW_run (WorkerArgs { .. })) = do
-  let ___ = putStrLn ((List.concat
-                       $ List.take 72
-                       $ List.cycle ["_"]) :: Prelude.String)
-
-  withWorkerEnv worker_toml $ \env -> do
-    let log_cfg = env ^. hasConfig . gc_logging
-    withLogger log_cfg $ \ioLogger -> do
-      ___
-      logMsg ioLogger INFO "GarganText worker"
-      logMsg ioLogger INFO $ "worker_name: " <> T.unpack worker_name
-      logMsg ioLogger INFO $ "worker toml: " <> _SettingsFile worker_toml
-      ___
-      
-      let ws = env ^. hasConfig . gc_worker
-      case findDefinitionByName ws worker_name of
-        Nothing -> do
-          let workerNames = _wdName <$> (_wsDefinitions ws)
-          let availableWorkers = T.intercalate ", " workerNames
-          putText $ "Worker definition not found! Available workers: " <> availableWorkers
-        Just wd -> do
-          logMsg ioLogger INFO $ "Starting worker '" <> T.unpack worker_name <> "'"
-          logMsg ioLogger DEBUG $ "gc config: " <> show (env ^. hasConfig)
-          logMsg ioLogger DEBUG $ "Worker settings: " <> show ws
-          ___
-          if worker_run_single then
-            withPGMQWorkerSingleCtrlC env wd $ \a _state -> do
-              wait a
-          else
-            withPGMQWorkerCtrlC env wd $ \a _state -> do
-              -- _ <- runReaderT (sendJob Ping) env
-              wait a
-workerCLI (CLIW_runAll (WorkerAllArgs { .. })) = withWorkerEnv worker_toml $ \env -> do
-  let log_cfg = env ^. hasConfig . gc_logging
-  withLogger log_cfg $ \ioLogger -> runAllWorkers ioLogger worker_toml
+  cfg <- readConfig worker_toml
+  let ws = cfg ^. gc_worker
+  case findDefinitionByName ws worker_name of
+    Nothing -> do
+      let workerNames = _wdName <$> (_wsDefinitions ws)
+      let availableWorkers = T.intercalate ", " workerNames
+      panicTrace $ "Worker definition not found! Available workers: " <> availableWorkers
+    Just wd -> do
+      withWorkerEnv worker_toml (T.unpack worker_name) $ \env -> do
+        runWorkerMonad env $ do
+          logM INFO $ "Starting worker '" <> worker_name <> "'"
+          logM DEBUG $ "gc config: " <> show (env ^. hasConfig)
+          logM DEBUG $ "Worker settings: " <> show ws
+        if worker_run_single then
+          withPGMQWorkerSingleCtrlC env wd $ \a _state -> do
+            wait a
+        else
+          withPGMQWorkerCtrlC env wd $ \a _state -> do
+            -- _ <- runReaderT (sendJob Ping) env
+            wait a
+workerCLI (CLIW_runAll (WorkerAllArgs { .. })) = do
+  runAllWorkers worker_toml
 workerCLI (CLIW_stats (WorkerStatsArgs { .. })) = do
-  putStrLn ("worker toml: " <> _SettingsFile ws_toml)
-
-  withWorkerEnv ws_toml $ \env -> do
-    let ws = env ^. hasConfig . gc_worker
-    mapM_ (\wd -> do
-              state' <- initWorkerState env wd
-              let b = W.broker state'
-              let q = W.queueName state'
-              qs <- BT.getQueueSize b q
-              msgIds <- BT.listPendingMessageIds b q
-              putStrLn ("Queue: " <> show q <> ", size: " <> show qs :: Text)
-              putStrLn ("  Messages: " :: Text)
-              mapM_ (\msgId -> do
-                        mm <- BT.getMessageById b q msgId
+  cfg <- readConfig ws_toml
+  let ws = cfg ^. gc_worker
+  mapM_ (\wd -> withWorkerEnv ws_toml (T.unpack $ _wdName wd) $ \env -> do
+            state' <- initWorkerState env wd
+            let b = W.broker state'
+            let q = W.queueName state'
+            qs <- BT.getQueueSize b q
+            msgIds <- BT.listPendingMessageIds b q
+            runWorkerMonad env $ do
+              logM INFO $ ("Queue: " <> show q <> ", size: " <> show qs :: Text)
+              logM INFO $ ("  Messages: " :: Text)
+            mapM_ (\msgId -> do
+                      mm <- BT.getMessageById b q msgId
+                      runWorkerMonad env $ do
                         case mm of
-                          Nothing -> putStrLn ("  - " <> show msgId <> " :: NOTHING!" :: Text)
-                          Just m -> putStrLn ("  - " <> show m :: Text)
-                        ) msgIds
-              ) (_wsDefinitions ws)
+                          Nothing -> logM ERROR ("  - " <> show msgId <> " :: NOTHING!" :: Text)
+                          Just m -> logM INFO ("  - " <> show m :: Text)
+                      ) msgIds
+            ) (_wsDefinitions ws)
 
 
 workerCmd :: HasCallStack => Mod CommandFields CLI
@@ -135,12 +121,13 @@ stats_p = fmap CLIW_stats $ WorkerStatsArgs
 -- 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
+runAllWorkers :: SettingsFile -> IO ()
+runAllWorkers worker_toml = do
   cfg <- readConfig worker_toml
   let ws = cfg ^. gc_worker
   forConcurrently_ (_wsDefinitions ws) $ \wd -> do
-    withWorkerEnv worker_toml $ \env -> do
-      logMsg ioLogger INFO $ "Starting worker '" <> T.unpack (_wdName wd) <> "' (queue " <> show (_wdQueue wd) <> ")"
+    withWorkerEnv worker_toml (T.unpack $ _wdName wd) $ \env -> do
+      runWorkerMonad env $ do
+        logM INFO $ "Starting worker '" <> _wdName wd <> "' (queue " <> show (_wdQueue wd) <> ")"
       withPGMQWorkerCtrlC env wd $ \a _state -> do
         wait a

src/Gargantext/Core/Worker/Env.hs

@@ -20,7 +20,7 @@ module Gargantext.Core.Worker.Env where
 
 import Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVarIO, readTVarIO)
 import Control.Exception.Safe qualified as CES
-import Control.Lens (prism', to, view)
+import Control.Lens (prism', to, view, (%~), _Just)
 import Control.Lens.TH
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Maybe (fromJust)
@@ -31,7 +31,7 @@ import Gargantext.API.Job (RemainingSteps(..), jobLogStart, jobLogProgress, jobL
 import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
 import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
-import Gargantext.Core.Config (GargConfig(..), HasConfig(..), gc_logging, LogConfig)
+import Gargantext.Core.Config (GargConfig(..), HasConfig(..), gc_logging, LogConfig, lc_log_file)
 import Gargantext.Core.Config.Mail qualified as Mail
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Config.Types (SettingsFile(..))
@@ -48,6 +48,7 @@ import Gargantext.System.Logging (HasLogger(..), Logger, LogLevel(..), MonadLogg
 import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
 import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))
 import Prelude qualified
+import System.FilePath ((</>), takeDirectory, takeFileName, takeBaseName, takeExtension)
 import System.Log.FastLogger qualified as FL
 import Gargantext.System.Logging.Loggers
 
@@ -69,10 +70,20 @@ data WorkerJobState = WorkerJobState
   deriving (Show, Eq)
 
 
-withWorkerEnv :: SettingsFile -> (WorkerEnv -> IO a) -> IO a
-withWorkerEnv settingsFile k = do
+withWorkerEnv :: SettingsFile -> Prelude.String -> (WorkerEnv -> IO a) -> IO a
+withWorkerEnv settingsFile workerName k = do
   cfg <- readConfig settingsFile
-  withLoggerIO (cfg ^. gc_logging) $ \logger -> do
+  -- each worker should have it's own log file, not to conflict with the server
+  let modifyFileName path = dir </> (base ++ suffix ++ ext)
+        where
+          dir = takeDirectory path
+          filename = takeFileName path
+          base = takeBaseName filename
+          ext = takeExtension filename
+          suffix = "-worker-" <> workerName
+  let workerLogging = (lc_log_file . _Just) %~ modifyFileName $ cfg ^. gc_logging
+  putText $ "workerLogging: " <> show workerLogging
+  withLoggerIO workerLogging $ \logger -> do
     env <- newWorkerEnv logger cfg
     k env -- `finally` cleanEnv env
 

src/Gargantext/System/Logging/Loggers.hs

@@ -33,7 +33,7 @@ data IOStdLogger =
               }
 
 ioStdLogger :: LogConfig -> IO IOStdLogger
-ioStdLogger LogConfig{..} = do
+ioStdLogger LogConfig { _lc_log_file = Nothing, _lc_log_level } = do
   let minLvl = _lc_log_level
   let log_msg lvl msg = do
         t <- getCurrentTime
@@ -46,6 +46,21 @@ ioStdLogger LogConfig{..} = do
     , _iosl_log_msg   = log_msg
     , _iosl_log_txt = \lvl msg -> log_msg lvl (T.unpack msg)
     }
+ioStdLogger LogConfig { _lc_log_file = Just fpath, _lc_log_level } = do
+  let minLvl = _lc_log_level
+  let logType = FL.LogFileNoRotate fpath FL.defaultBufSize
+  (logger, loggerClose) <- FL.newFastLogger logType
+  let log_msg lvl msg = do
+        t <- getCurrentTime
+        when (lvl >= minLvl) $ do
+          let pfx = "[" <> show t <> "] [" <> show lvl <> "] "
+          logger $ FL.toLogStr $ pfx <> msg
+  pure $ IOStdLogger
+    { _iosl_log_level = minLvl
+    , _iosl_destroy   = loggerClose
+    , _iosl_log_msg   = log_msg
+    , _iosl_log_txt = \lvl msg -> log_msg lvl (T.unpack msg)
+    }
 
 -- | A monadic standard logger powered by fast-logger underneath.
 data MonadicStdLogger payload m =