Merge remote-tracking branch 'origin/adinapoli/issue-440' into dev

bin/gargantext-cli/CLI/Ini.hs

@@ -19,17 +19,17 @@ Import a corpus binary.
 module CLI.Ini where
 
 import CLI.Types
-import Control.Monad.Logger (LogLevel(LevelDebug))
-import Data.Text qualified as T
-import Data.Text.IO qualified as T (writeFile)
 import Database.PostgreSQL.Simple qualified as PGS
-import Gargantext.Core.Config qualified as Config
+import Data.Text.IO qualified as T (writeFile)
+import Data.Text qualified as T
 import Gargantext.Core.Config.Ini.Ini qualified as Ini
 import Gargantext.Core.Config.Ini.Mail qualified as IniMail
 import Gargantext.Core.Config.Ini.NLP qualified as IniNLP
+import Gargantext.Core.Config qualified as Config
 import Gargantext.Core.Config.Types qualified as CTypes
 import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
 import Gargantext.Prelude
+import Gargantext.System.Logging (LogLevel(..))
 import Options.Applicative
 import Servant.Client.Core (parseBaseUrl)
 import Toml qualified
@@ -87,7 +87,10 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
                                                   , _wsDefaultVisibilityTimeout = 1
                                                   , _wsDefaultDelay = 0
                                                   , _wsDatabase = connInfo { PGS.connectDatabase = "pgmq"} }
-                    , _gc_log_level = LevelDebug
+                    , _gc_logging = Config.LogConfig {
+                        _lc_log_level = INFO
+                      , _lc_log_file = Nothing
+                      }
                     }
   where
     _ac_scrapyd_url =

bin/gargantext-cli/CLI/Server.hs

@@ -12,31 +12,39 @@ Portability : POSIX
 
 module CLI.Server where
 
-import Data.Version (showVersion)
 import CLI.Parsers (settings_p)
 import CLI.Types
 import CLI.Worker (runAllWorkers)
-import GHC.IO.Encoding (setLocaleEncoding, utf8)
-import Gargantext.API (startGargantext)
+import Control.Monad.IO.Class
+import Data.Version (showVersion)
 import Gargantext.API.Admin.EnvTypes (Mode(..))
+import Gargantext.API (startGargantext)
+import Gargantext.Core.Config
 import Gargantext.Core.Config.Types (_SettingsFile)
+import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Prelude
-import Gargantext.System.Logging (withLogger, logMsg, LogLevel(..), Logger)
+import Gargantext.System.Logging
+import GHC.IO.Encoding (setLocaleEncoding, utf8)
 import Options.Applicative
 import Paths_gargantext qualified as PG -- cabal magic build module
 
-
+withServerCLILogger :: ServerArgs
+                    -> (Logger IO -> IO a)
+                    -> IO a
+withServerCLILogger ServerArgs{..} f = do
+  cfg  <- liftIO $ readConfig server_toml
+  withLogger (cfg ^. gc_logging) $ \logger -> f logger
 
 serverCLI :: CLIServer -> IO ()
-serverCLI (CLIS_start serverArgs) = withLogger () $ \ioLogger ->
+serverCLI (CLIS_start serverArgs) = withServerCLILogger serverArgs $ \ioLogger ->
   startServerCLI ioLogger serverArgs
 
-serverCLI (CLIS_startAll serverArgs@(ServerArgs { .. })) = withLogger () $ \ioLogger -> do
+serverCLI (CLIS_startAll serverArgs@(ServerArgs { .. })) = withServerCLILogger serverArgs $ \ioLogger -> do
   withAsync (startServerCLI ioLogger serverArgs) $ \aServer -> do
     runAllWorkers ioLogger server_toml
     wait aServer
 
-serverCLI (CLIS_version) = withLogger () $ \ioLogger -> do
+serverCLI (CLIS_version) = withLogger (LogConfig Nothing DEBUG) $ \ioLogger -> do
     -- Sets the locale to avoid encoding issues like in #284.
   setLocaleEncoding utf8
   logMsg ioLogger INFO $ "Version: " <> showVersion PG.version
@@ -58,13 +66,13 @@ serverParser = hsubparser (
 
 start_p :: Parser CLIServer
 start_p = fmap CLIS_start $ ServerArgs
-  <$> mode_p 
+  <$> mode_p
   <*> port_p
   <*> settings_p
 
 start_all_p :: Parser CLIServer
 start_all_p = fmap CLIS_startAll $ ServerArgs
-  <$> mode_p 
+  <$> mode_p
   <*> port_p
   <*> settings_p
 
@@ -81,7 +89,7 @@ port_p = option auto ( long "port"
                     <> showDefault
                     <> value 8008
                     <> help "Port" )
-  
+
 version_p :: Parser CLIServer
 version_p = pure CLIS_version
 

bin/gargantext-cli/CLI/Worker.hs

@@ -19,7 +19,7 @@ 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)
+import Gargantext.Core.Config (hasConfig, gc_worker, gc_logging)
 import Gargantext.Core.Config.Types (SettingsFile(..))
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Config.Worker (WorkerDefinition(..), WorkerSettings(..), findDefinitionByName)
@@ -67,8 +67,9 @@ workerCLI (CLIW_run (WorkerArgs { .. })) = do
           withPGMQWorkerCtrlC env wd $ \a _state -> do
             -- _ <- runReaderT (sendJob Ping) env
             wait a
-workerCLI (CLIW_runAll (WorkerAllArgs { .. })) = withLogger () $ \ioLogger -> do
-  runAllWorkers ioLogger worker_toml
+workerCLI (CLIW_runAll (WorkerAllArgs { .. })) = withWorkerEnv worker_toml $ \env -> do
+  let log_cfg = env ^. hasConfig . gc_logging
+  withLogger log_cfg $ \ioLogger -> runAllWorkers ioLogger worker_toml
 workerCLI (CLIW_stats (WorkerStatsArgs { .. })) = do
   putStrLn ("worker toml: " <> _SettingsFile ws_toml)
 

gargantext-settings.toml_toModify

@@ -102,7 +102,7 @@ pass = PASSWORD_TO_CHANGE
 
 [logs]
 log_file = "/var/log/gargantext/backend.log"
-log_level = "LevelDebug"
+log_level = "info"
 log_formatter = "verbose"
 
 

gargantext.cabal

@@ -97,7 +97,7 @@ flag test-crypto
 -- debug output for the phylo code, so that it doesn't
 -- hinder its performance.
 flag no-phylo-debug-logs
-  default: False
+  default: True
   manual: True
 
 flag enable-benchmarks
@@ -308,6 +308,7 @@ library
       Gargantext.Orphans.Accelerate
       Gargantext.Orphans.OpenAPI
       Gargantext.System.Logging
+      Gargantext.System.Logging.Types
       Gargantext.Utils.Dict
       Gargantext.Utils.Jobs.Error
       Gargantext.Utils.Jobs.Monad
@@ -695,7 +696,6 @@ executable gargantext
     , gargantext-prelude
     , haskell-bee
     , MonadRandom ^>= 0.6
-    , monad-logger ^>= 0.3.36
     , optparse-applicative
     , postgresql-simple >= 0.6.4 && <= 0.7.0.0
     , servant >= 0.20.1 && < 0.21

hie.yaml

@@ -4,61 +4,61 @@ cradle:
       component: "lib:gargantext"
 
     - path: "./bin/gargantext-cli/Main.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Admin.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/FileDiff.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/FilterTermsAndCooc.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Import.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Ini.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Init.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Invitations.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/ObfuscateDB.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Parsers.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Phylo.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Phylo/Common.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Phylo/Profile.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Server/Routes.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Types.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/CLI/Upgrade.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-cli/Paths_gargantext.hs"
-      component: "gargantext:exe:gargantext-cli"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-server/Main.hs"
-      component: "gargantext:exe:gargantext-server"
+      component: "gargantext:exe:gargantext"
 
     - path: "./bin/gargantext-server/Paths_gargantext.hs"
-      component: "gargantext:exe:gargantext-server"
+      component: "gargantext:exe:gargantext"
 
     - path: "./test"
       component: "gargantext:test:garg-test-tasty"

src/Gargantext/API.hs

@@ -48,14 +48,14 @@ import Gargantext.API.Middleware (logStdoutDevSanitised)
 import Gargantext.API.Routes.Named (API)
 import Gargantext.API.Routes.Named.EKG (EkgAPI)
 import Gargantext.API.Server.Named (server)
-import Gargantext.Core.Config (gc_notifications_config, gc_frontend_config)
+import Gargantext.Core.Config
 import Gargantext.Core.Config.Types (CORSOrigin(..), CORSSettings, MicroServicesProxyStatus(..), NotificationsConfig(..), PortNumber, SettingsFile(..), corsAllowedOrigins, fc_appPort, fc_cors, fc_cookie_settings, microServicesProxyStatus)
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Notifications (withNotifications)
 import Gargantext.Database.Prelude qualified as DB
 import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
 import Gargantext.Prelude hiding (putStrLn, to)
-import Gargantext.System.Logging (withLoggerHoisted)
+import Gargantext.System.Logging (withLoggerIO, renderLogLevel)
 import Network.HTTP.Types hiding (Query)
 import Network.Wai (Middleware, Request, requestHeaders)
 import Network.Wai.Handler.Warp hiding (defaultSettings)
@@ -70,21 +70,20 @@ import System.Cron.Schedule qualified as Cron
 
 -- | startGargantext takes as parameters port number and Toml file.
 startGargantext :: Mode -> PortNumber -> SettingsFile -> IO ()
-startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mode $ \logger -> do
+startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerIO mode $ \logger -> do
   config <- readConfig sf <&> (gc_frontend_config . fc_appPort) .~ port
   when (port /= config ^. gc_frontend_config . fc_appPort) $
     panicTrace "TODO: conflicting settings of port"
-  let nc = config ^. gc_notifications_config
-  withNotifications nc $ \dispatcher -> do
+  withNotifications config $ \dispatcher -> do
     env <- newEnv logger config dispatcher
     let fc = env ^. env_config . gc_frontend_config
     let proxyStatus = microServicesProxyStatus fc
     runDbCheck env
-    portRouteInfo nc port proxyStatus
+    startupInfo config port proxyStatus
     app <- makeApp env
     mid <- makeGargMiddleware (fc ^. fc_cors) mode
     periodicActions <- schedulePeriodicActions env
-  
+
     let runServer = run port (mid app) `finally` stopGargantext periodicActions
     case proxyStatus of
       PXY_disabled
@@ -94,7 +93,7 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mod
           proxyCache <- InMemory.newCache (Just oneHour)
           let runProxy  = run proxyPort (mid (microServicesProxyApp proxyCache env))
           Async.race_ runServer runProxy
-  
+
   where runDbCheck env = do
           r <- runExceptT (runReaderT DB.dbCheck env) `catch`
             (\(err :: SomeException) -> pure $ Left err)
@@ -106,11 +105,12 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mod
             Left err -> panicTrace $ "Unexpected exception:" <> show err
         oneHour = Clock.fromNanoSecs 3600_000_000_000
 
-portRouteInfo :: NotificationsConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
-portRouteInfo nc mainPort proxyStatus = do
+startupInfo :: GargConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
+startupInfo config mainPort proxyStatus = do
   putStrLn   "=========================================================================================================="
-  putStrLn   " GarganText Main Routes"
+  putStrLn   " GarganText Server"
   putStrLn   "=========================================================================================================="
+  putStrLn $ " - Log Level ...............................: " <> renderLogLevel ll
   putStrLn $ " - Web GarganText Frontend..................: " <> "http://localhost:" <> toUrlPiece mainPort <> "/index.html"
   putStrLn $ " - Swagger UI (API documentation)...........: " <> "http://localhost:" <> toUrlPiece mainPort <> "/swagger-ui"
   putStrLn $ " - Playground GraphQL (API documentation)...: " <> "http://localhost:" <> toUrlPiece mainPort <> "/gql"
@@ -121,6 +121,8 @@ portRouteInfo nc mainPort proxyStatus = do
   putStrLn $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece mainPort <> "/ws"
   putStrLn   "=========================================================================================================="
   where
+    nc = config ^. gc_notifications_config
+    ll = config ^. gc_logging . lc_log_level
     renderProxyStatus = case proxyStatus of
       PXY_disabled ->
         " - Microservices proxy .....................: DISABLED (enable in gargantext-settings.toml)"

src/Gargantext/API/Admin/EnvTypes.hs

@@ -25,7 +25,7 @@ module Gargantext.API.Admin.EnvTypes (
   , env_jwt_settings
   , env_pool
   , env_nodeStory
-  
+
   , menv_firewall
   , dev_env_logger
 
@@ -43,7 +43,7 @@ import Database.PostgreSQL.Simple (Connection)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
 import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Prelude (GargM, IsGargServer)
-import Gargantext.Core.Config (GargConfig(..), gc_mail_config, gc_nlp_config, HasJWTSettings(..), HasConfig(..), HasManager(..))
+import Gargantext.Core.Config (GargConfig(..), gc_mail_config, gc_nlp_config, HasJWTSettings(..), HasConfig(..), HasManager(..), gc_logging, lc_log_level)
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap)
 import Gargantext.Core.NodeStory
@@ -73,28 +73,6 @@ modeToLoggingLevels = \case
    -- For production, accepts everything but DEBUG.
    Prod -> [minBound .. maxBound] \\ [DEBUG]
 
-instance MonadLogger (GargM Env BackendInternalError) where
-  getLogger = asks _env_logger
-
-instance HasLogger (GargM Env BackendInternalError) where
-  data instance Logger (GargM Env BackendInternalError)  =
-    GargLogger {
-        logger_mode    :: Mode
-      , logger_set     :: FL.LoggerSet
-      }
-  type instance LogInitParams (GargM Env BackendInternalError) = Mode
-  type instance LogPayload (GargM Env BackendInternalError)    = FL.LogStr
-  initLogger mode = do
-    logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
-    pure $ GargLogger mode logger_set
-  destroyLogger (GargLogger{..}) = liftIO $ FL.rmLoggerSet logger_set
-  logMsg (GargLogger mode logger_set) lvl msg = do
-    let pfx = "[" <> show lvl <> "] " :: Text
-    when (lvl `elem` (modeToLoggingLevels mode)) $
-      liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
-  logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
-
-
 -- Do /not/ treat the data types of this type as strict, because it's convenient
 -- to be able to partially initialise things like an 'Env' during tests, without
 -- having to specify /everything/. This means that when we /construct/ an 'Env',
@@ -142,7 +120,7 @@ instance HasDispatcher Env Dispatcher where
 instance CET.HasCentralExchangeNotification Env where
   ce_notify m = do
     c <- asks (view env_config)
-    liftBase $ CE.notify (_gc_notifications_config c) m
+    liftBase $ CE.notify c m
 
 instance HasManager Env where
   gargHttpManager = env_manager
@@ -190,7 +168,7 @@ makeLenses ''DevEnv
 instance CET.HasCentralExchangeNotification DevEnv where
   ce_notify m = do
     nc <- asks (view dev_env_config)
-    liftBase $ CE.notify (_gc_notifications_config nc) m
+    liftBase $ CE.notify nc m
 
 -- | Our /mock/ job handle.
 data DevJobHandle = DevJobHandle
@@ -244,5 +222,28 @@ instance HasManager DevEnv where
 instance HasNLPServer DevEnv where
   nlpServer = dev_env_config . gc_nlp_config . (to nlpServerMap)
 
-
 instance IsGargServer Env BackendInternalError (GargM Env BackendInternalError)
+
+instance HasLogger (GargM Env BackendInternalError) where
+  data instance Logger (GargM Env BackendInternalError)  =
+    GargLogger {
+        logger_mode    :: Mode
+      , logger_set     :: FL.LoggerSet
+      }
+  type instance LogInitParams (GargM Env BackendInternalError) = Mode
+  type instance LogPayload (GargM Env BackendInternalError)    = FL.LogStr
+  initLogger mode = do
+    logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
+    pure $ GargLogger mode logger_set
+  destroyLogger (GargLogger{..}) = liftIO $ FL.rmLoggerSet logger_set
+  logMsg (GargLogger mode logger_set) lvl msg = do
+    cfg <- view hasConfig
+    let minLvl = cfg ^. gc_logging . lc_log_level
+    when (lvl >= minLvl) $ do
+      let pfx = "[" <> show lvl <> "] " :: Text
+      when (lvl `elem` (modeToLoggingLevels mode)) $
+        liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
+  logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
+
+instance MonadLogger (GargM Env BackendInternalError) where
+  getLogger = asks _env_logger

src/Gargantext/API/Admin/Settings.hs

@@ -62,7 +62,7 @@ settingsFromEnvironment =
     Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
              <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
              <*> optSetting "PORT" 3000
-             <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
+             <*> (parseLogLevel <$> optSetting "GGTX_LOG_LEVEL" "warn")
              <*> reqSetting "DB_SERVER"
              <*> (parseJwk <$> reqSetting "JWT_SECRET")
              <*> optSetting "SEND_EMAIL" SendEmailViaAws

src/Gargantext/API/Dev.hs

@@ -26,13 +26,13 @@ import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
 import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd)
 import Gargantext.Prelude
-import Gargantext.System.Logging ( withLoggerHoisted )
+import Gargantext.System.Logging ( withLoggerIO )
 import Network.HTTP.Client.TLS (newTlsManager)
 import Servant ( ServerError )
 
 -------------------------------------------------------------------
 withDevEnv :: SettingsFile -> (DevEnv -> IO a) -> IO a
-withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
+withDevEnv settingsFile k = withLoggerIO Dev $ \logger -> do
   env <- newDevEnv logger
   k env -- `finally` cleanEnv env
 

src/Gargantext/API/Ngrams.hs

@@ -21,6 +21,7 @@ add get
 {-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE IncoherentInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeFamilies      #-}
 {-# LANGUAGE TypeOperators     #-}
 
@@ -84,13 +85,13 @@ module Gargantext.API.Ngrams
 import Control.Lens (view, (^..), (+~), (%~), msumOf, at, ix, _Just, Each(..), (%%~), ifolded, to, withIndex, over)
 import Data.Aeson.Text qualified as DAT
 import Data.List qualified as List
-import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
+import Data.Map.Strict qualified as Map
 import Data.Patch.Class (Action(act), Transformable(..), ours)
 import Data.Set qualified as Set
 import Data.Text (isInfixOf, toLower, unpack)
 import Data.Text.Lazy.IO as DTL ( writeFile )
-import Formatting (hprint, int, (%))
+import Formatting (sformat, int, (%))
 import Gargantext.API.Ngrams.Tools (getNodeStory)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory (ArchiveList, HasNodeStory, HasNodeArchiveStoryImmediateSaver(..), HasNodeStoryImmediateSaver(..), NgramsStatePatch', a_history, a_state, a_version, currentVersion)
@@ -99,8 +100,9 @@ import Gargantext.Core.Types (ListType(..), NodeId, ListId, TODO, assertValid, H
 import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
 import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast)
 import Gargantext.Database.Query.Table.Ngrams ( text2ngrams, insertNgrams )
-import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
 import Gargantext.Prelude.Clock (hasTime, getTime)
+import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
+import Gargantext.System.Logging
 import Text.Collate qualified as Unicode
 
 
@@ -517,7 +519,9 @@ unicodeDUCETSorter :: Text -> Text -> Ordering
 unicodeDUCETSorter = Unicode.collate Unicode.rootCollator
 
 getTableNgrams :: forall env err m.
-                  ( HasNodeStory env err m )
+                  ( HasNodeStory env err m
+                  , MonadLogger m
+                  )
                => NodeId
                -> ListId
                -> TabType
@@ -531,7 +535,9 @@ getTableNgrams nodeId listId tabType searchQuery = do
 
 -- | Helper function to get the ngrams table with scores.
 getNgramsTable' :: forall env err m.
-                   ( HasNodeStory env err m )
+                   ( HasNodeStory env err m
+                   , MonadLogger m
+                   )
                 => NodeId
                 -> ListId
                 -> NgramsType
@@ -544,7 +550,9 @@ getNgramsTable' nId listId ngramsType = do
 -- | Helper function to set scores on an `NgramsTable`.
 setNgramsTableScores :: forall env err m t.
                         ( Each t t NgramsElement NgramsElement
-                        , HasNodeStory env err m )
+                        , HasNodeStory env err m
+                        , MonadLogger m
+                        )
                      => NodeId
                      -> ListId
                      -> NgramsType
@@ -555,12 +563,9 @@ setNgramsTableScores nId listId ngramsType table = do
   occurrences <- getOccByNgramsOnlyFast nId listId ngramsType
   --printDebug "[setNgramsTableScores] occurrences" occurrences
   t2 <- getTime
-  liftBase $ do
-    let ngrams_terms = table ^.. each . ne_ngrams
-    -- printDebug "ngrams_terms" ngrams_terms
-    hprint stderr
-      ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
-      (length ngrams_terms) t1 t2
+  let ngrams_terms = table ^.. each . ne_ngrams
+  $(logLocM) DEBUG $ "ngrams_terms: " <> show ngrams_terms
+  $(logLocM) DEBUG $ sformat ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n") (length ngrams_terms) t1 t2
   let
     setOcc ne = ne & ne_occurrences .~ Set.fromList (msumOf (ix (ne ^. ne_ngrams)) occurrences)
 
@@ -580,7 +585,7 @@ needsScores (Just ScoreAsc)  = True
 needsScores (Just ScoreDesc) = True
 needsScores _ = False
 
-getTableNgramsCorpus :: ( HasNodeStory env err m )
+getTableNgramsCorpus :: ( HasNodeStory env err m, MonadLogger m )
                      => NodeId
                      -> TabType
                      -> ListId

src/Gargantext/API/Server/Named/Ngrams.hs

@@ -9,8 +9,8 @@ module Gargantext.API.Server.Named.Ngrams (
 import Control.Lens ((%%~))
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
-import Gargantext.API.Admin.Auth (withNamedAccess)
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser, PathId (..))
+import Gargantext.API.Admin.Auth (withNamedAccess)
 import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Metrics qualified as Metrics
@@ -25,11 +25,12 @@ import Gargantext.Core.Types.Query (Limit(..), Offset(..))
 import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Query.Table.Ngrams ( selectNgramsByDoc )
-import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername )
 import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
 import Gargantext.Prelude
+import Gargantext.System.Logging
 import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..), markFailedNoErr)
 import Servant.Server.Generic (AsServerT)
 
@@ -150,7 +151,7 @@ tableNgramsPostChartsAsync utn jobHandle = do
   -}
 
 scoresRecomputeTableNgrams :: forall env err m.
-                              ( HasNodeStory env err m, HasNodeError err )
+                              ( HasNodeStory env err m, HasNodeError err, MonadLogger m )
                            => NodeId -> TabType -> ListId -> m Int
 scoresRecomputeTableNgrams nId tabType listId = do
   tableMap <- getNgramsTableMap listId ngramsType
@@ -163,7 +164,9 @@ scoresRecomputeTableNgrams nId tabType listId = do
 
 -- | Text search is deactivated for now for ngrams by doc only
 getTableNgramsDoc :: ( HasNodeStory env err m
-                     , HasNodeError err )
+                     , HasNodeError err
+                     , MonadLogger m
+                     )
                   => DocId -> TabType
                   -> ListId -> Limit -> Maybe Offset
                   -> Maybe ListType

src/Gargantext/API/Worker.hs

@@ -36,7 +36,7 @@ serveWorkerAPI f = WorkerAPI { workerAPIPost }
   where
     workerAPIPost i = do
       let job = f i
-      logM DDEBUG $ "[serveWorkerAPI] sending job " <> show job
+      logM DEBUG $ "[serveWorkerAPI] sending job " <> show job
       mId <- sendJob job
       pure $ JobInfo { _ji_message_id = mId
                      , _ji_mNode_id = getWorkerMNodeId job }
@@ -54,4 +54,4 @@ serveWorkerAPIEJob f = WorkerAPI { workerAPIPost }
           mId <- sendJob job
           pure $ JobInfo { _ji_message_id = mId
                          , _ji_mNode_id = getWorkerMNodeId job }
-    
+

src/Gargantext/Core/Config.hs

@@ -12,10 +12,12 @@ Configuration for the gargantext server
 -}
 
 {-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE LambdaCase          #-}
 
 module Gargantext.Core.Config (
     -- * Types
     GargConfig(..)
+  , LogConfig(..)
 
     -- * Lenses
   , gc_datafilepath
@@ -29,7 +31,9 @@ module Gargantext.Core.Config (
   , gc_secrets
   , gc_apis
   , gc_worker
-  , gc_log_level
+  , gc_logging
+  , lc_log_level
+  , lc_log_file
 
   , mkProxyUrl
 
@@ -39,24 +43,43 @@ module Gargantext.Core.Config (
   ) where
 
 import Control.Lens (Getter)
-import Control.Monad.Logger (LogLevel(LevelDebug))
-import Data.Text as T
+import Gargantext.System.Logging.Types (LogLevel, parseLogLevel)
 import Database.PostgreSQL.Simple qualified as PSQL
+import Data.Text as T
 import Gargantext.Core.Config.Mail (MailConfig)
 import Gargantext.Core.Config.NLP (NLPConfig)
-import Gargantext.Core.Config.Worker (WorkerSettings)
 import Gargantext.Core.Config.Types
+import Gargantext.Core.Config.Worker (WorkerSettings)
 import Gargantext.Prelude
 import Network.HTTP.Client qualified as HTTP
 import Servant.Auth.Server (JWTSettings)
 import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)
 import Toml.Schema
+import Toml.Schema.FromValue (typeError)
 
 
 -- | strip a given character from end of string
 -- stripRight :: Char -> T.Text -> T.Text
 -- stripRight c s = if T.last s == c then stripRight c (T.take (T.length s - 1) s) else s
 
+data LogConfig = LogConfig
+  { _lc_log_file  :: Maybe FilePath
+  , _lc_log_level :: !LogLevel
+  } deriving Show
+
+instance FromValue LogConfig where
+  fromValue = parseTableFromValue $ do
+    _lc_log_file  <- optKey "log_file"
+    _lc_log_level <- reqKeyOf "log_level" parse_log_level
+    pure LogConfig{..}
+
+parse_log_level :: Value' l -> Matcher l LogLevel
+parse_log_level = \case
+  Text' a txt -> case parseLogLevel txt of
+    Left err  -> typeError (T.unpack err) (Text' a txt)
+    Right ll  -> pure ll
+  xs          -> typeError "parse_log_level" xs
+
 -- Non-strict data so that we can use it in tests
 data GargConfig = GargConfig { _gc_datafilepath         :: ~FilePath
                              -- , _gc_repofilepath      :: ~FilePath
@@ -70,12 +93,10 @@ data GargConfig = GargConfig { _gc_datafilepath         :: ~FilePath
                              , _gc_secrets              :: ~SecretsConfig
                              , _gc_apis                 :: ~APIsConfig
                              , _gc_worker               :: ~WorkerSettings
-                             , _gc_log_level            :: ~LogLevel
+                             , _gc_logging              :: ~LogConfig
                              }
   deriving (Generic, Show)
 
-makeLenses ''GargConfig
-
 instance FromValue GargConfig where
   fromValue = parseTableFromValue $ do
     _gc_frontend_config <- reqKey "frontend"
@@ -89,7 +110,7 @@ instance FromValue GargConfig where
     _gc_apis <- reqKey "apis"
     _gc_notifications_config <- reqKey "notifications"
     _gc_worker <- reqKey "worker"
-    let _gc_log_level = LevelDebug
+    _gc_logging <- reqKey "logs"
     return $ GargConfig { _gc_datafilepath
                         , _gc_jobs
                         , _gc_apis
@@ -101,7 +122,7 @@ instance FromValue GargConfig where
                         , _gc_frames
                         , _gc_secrets
                         , _gc_worker
-                        , _gc_log_level }
+                        , _gc_logging }
 instance ToValue GargConfig where
   toValue = defaultTableToValue
 instance ToTable GargConfig where
@@ -139,3 +160,11 @@ class HasJWTSettings env where
 
 class HasManager env where
   gargHttpManager :: Getter env HTTP.Manager
+
+--
+-- Lenses
+--
+
+makeLenses ''LogConfig
+makeLenses ''GargConfig
+

src/Gargantext/Core/Notifications.hs

@@ -12,14 +12,14 @@ Portability : POSIX
 module Gargantext.Core.Notifications
 where
 
-import Gargantext.Core.Config.Types (NotificationsConfig)
+import Gargantext.Core.Config (GargConfig)
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
 import Gargantext.Core.Notifications.Dispatcher qualified as D
 import Protolude
 
 
-withNotifications :: NotificationsConfig -> (D.Dispatcher -> IO a) -> IO a
-withNotifications nc cb =
-  D.withDispatcher nc $ \dispatcher -> do
-    withAsync (CE.gServer nc) $ \_ce -> do
+withNotifications :: GargConfig -> (D.Dispatcher -> IO a) -> IO a
+withNotifications gc cb =
+  D.withDispatcher gc $ \dispatcher -> do
+    withAsync (CE.gServer gc) $ \_ce -> do
       cb dispatcher

src/Gargantext/Core/Notifications/CentralExchange.hs

@@ -11,7 +11,7 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
 
 Docs:
 https://dev.sub.gargantext.org/#/share/Notes/187918
-    
+
 -}
 
 module Gargantext.Core.Notifications.CentralExchange (
@@ -23,15 +23,16 @@ import Control.Concurrent.Async qualified as Async
 import Control.Concurrent.STM.TChan qualified as TChan
 import Data.Aeson qualified as Aeson
 import Data.ByteString.Lazy qualified as BSL
-import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
+import Data.Text qualified as T
+import Gargantext.Core.Config (GargConfig, gc_notifications_config, gc_logging)
 import Gargantext.Core.Config.Types (NotificationsConfig(..))
 import Gargantext.Core.Notifications.CentralExchange.Types
 import Gargantext.Prelude
 import Gargantext.System.Logging (LogLevel(..), withLogger, logMsg)
 import Nanomsg (Pull(..), Push(..), bind, connect, recv, send, withSocket)
 import System.Timeout (timeout)
-    
+
 {-
 
 Central exchange is a service, which gathers messages from various
@@ -42,18 +43,18 @@ The primary goal is to be able to read as many messages as possible
 and then send them to the Dispatcher. Although nanomsg does some
 message buffering, we don't want these messages to pile up, especially
 with many users having updates.
-    
+
 -}
 
-gServer :: NotificationsConfig -> IO ()
-gServer (NotificationsConfig { .. }) = do
+gServer :: GargConfig -> IO ()
+gServer cfg = do
   withSocket Pull $ \s -> do
     withSocket Push $ \s_dispatcher -> do
-      withLogger () $ \ioLogger -> do
-        logMsg ioLogger DDEBUG $ "[central_exchange] binding to " <> T.unpack _nc_central_exchange_bind
+      withLogger log_cfg $ \ioLogger -> do
+        logMsg ioLogger DEBUG $ "[central_exchange] binding to " <> T.unpack _nc_central_exchange_bind
       _ <- bind s $ T.unpack _nc_central_exchange_bind
-      withLogger () $ \ioLogger -> do
-        logMsg ioLogger DDEBUG $ "[central_exchange] connecting to " <> T.unpack _nc_dispatcher_bind
+      withLogger log_cfg $ \ioLogger -> do
+        logMsg ioLogger DEBUG $ "[central_exchange] connecting to " <> T.unpack _nc_dispatcher_bind
       _ <- connect s_dispatcher $ T.unpack _nc_dispatcher_connect
 
       tChan <- TChan.newTChanIO
@@ -63,16 +64,18 @@ gServer (NotificationsConfig { .. }) = do
       -- | the 'tChan' and calls Dispatcher accordingly. This is to
       -- | make reading nanomsg as fast as possible.
       void $ Async.concurrently (worker s_dispatcher tChan) $ do
-        withLogger () $ \ioLogger -> do
+        withLogger log_cfg $ \ioLogger -> do
           forever $ do
             -- putText "[central_exchange] receiving"
             r <- recv s
-            logMsg ioLogger DDEBUG $ "[central_exchange] received: " <> show r
+            logMsg ioLogger DEBUG $ "[central_exchange] received: " <> show r
             -- C.putStrLn $ "[central_exchange] " <> r
             atomically $ TChan.writeTChan tChan r
   where
+    NotificationsConfig{..} = cfg ^. gc_notifications_config
+    log_cfg = cfg ^. gc_logging
     worker s_dispatcher tChan = do
-      withLogger () $ \ioLogger -> do
+      withLogger log_cfg $ \ioLogger -> do
         forever $ do
           r <- atomically $ TChan.readTChan tChan
           case Aeson.decode (BSL.fromStrict r) of
@@ -81,10 +84,10 @@ gServer (NotificationsConfig { .. }) = do
               -- putText $ "[central_exchange] sending that to the dispatcher: " <> show node_id
               -- To make this more robust, use withAsync so we don't
               -- block the main thread (send is blocking)
-              
+
               -- NOTE: If we're flooded with messages, and send is
               -- slow, we might be spawning many threads...
-    
+
               -- NOTE: Currently we just forward the message that we
               -- got. So in theory central exchange isn't needed (we
               -- could ping dispatcher directly). However, I think
@@ -102,16 +105,19 @@ gServer (NotificationsConfig { .. }) = do
               void $ timeout 100_000 $ send s_dispatcher r
             Nothing ->
               logMsg ioLogger ERROR $ "[central_exchange] cannot decode message: " <> show r
-      
 
-notify :: NotificationsConfig -> CEMessage -> IO ()
-notify (NotificationsConfig { _nc_central_exchange_connect }) ceMessage = do
+
+notify :: GargConfig -> CEMessage -> IO ()
+notify cfg ceMessage = do
   Async.withAsync (pure ()) $ \_ -> do
     withSocket Push $ \s -> do
       _ <- connect s $ T.unpack _nc_central_exchange_connect
       let str = Aeson.encode ceMessage
-      withLogger () $ \ioLogger ->
-        logMsg ioLogger DDEBUG $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
+      withLogger log_cfg $ \ioLogger ->
+        logMsg ioLogger DEBUG $ "[central_exchange] sending: " <> (T.unpack $ TE.decodeUtf8 $ BSL.toStrict str)
       -- err <- sendNonblocking s $ BSL.toStrict str
       -- putText $ "[notify] err: " <> show err
       void $ timeout 100_000 $ send s $ BSL.toStrict str
+  where
+    NotificationsConfig { _nc_central_exchange_connect } = cfg ^. gc_notifications_config
+    log_cfg = cfg ^. gc_logging

src/Gargantext/Core/Notifications/Dispatcher.hs

@@ -11,7 +11,7 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
 
 Docs:
 https://dev.sub.gargantext.org/#/share/Notes/187918
-    
+
 -}
 
 module Gargantext.Core.Notifications.Dispatcher (
@@ -38,6 +38,7 @@ import Gargantext.System.Logging (LogLevel(..), withLogger, logMsg)
 import Nanomsg (Pull(..), bind, recv, withSocket)
 import Network.WebSockets qualified as WS
 import StmContainers.Set qualified as SSet
+import Gargantext.Core.Config
 
 {-
 
@@ -45,7 +46,7 @@ Dispatcher is a service, which provides couple of functionalities:
 - handles WebSocket connections and manages them
 - accepts messages from central exchange
 - dispatches these messages to connected users
-    
+
 -}
 
 data Dispatcher =
@@ -55,23 +56,23 @@ data Dispatcher =
 dispatcherSubscriptions :: Dispatcher -> SSet.Set Subscription
 dispatcherSubscriptions = d_subscriptions
 
-withDispatcher :: NotificationsConfig -> (Dispatcher -> IO a) -> IO a
-withDispatcher nc cb = do
+withDispatcher :: GargConfig -> (Dispatcher -> IO a) -> IO a
+withDispatcher cfg cb = do
   subscriptions <- SSet.newIO
 
-  Async.withAsync (dispatcherListener nc subscriptions) $ \_a -> do
+  Async.withAsync (dispatcherListener cfg subscriptions) $ \_a -> do
     let dispatcher = Dispatcher { d_subscriptions = subscriptions }
     cb dispatcher
 
-    
+
 -- | This is a nanomsg socket listener. We want to read the messages
 -- | as fast as possible and then process them gradually in a separate
 -- | thread.
-dispatcherListener :: NotificationsConfig -> SSet.Set Subscription -> IO ()
-dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions = do
+dispatcherListener :: GargConfig -> SSet.Set Subscription -> IO ()
+dispatcherListener config subscriptions = do
   withSocket Pull $ \s -> do
-    withLogger () $ \ioLogger -> do
-      logMsg ioLogger DDEBUG $ "[dispatcherListener] binding to " <> T.unpack _nc_dispatcher_bind
+    withLogger log_cfg $ \ioLogger -> do
+      logMsg ioLogger DEBUG $ "[dispatcherListener] binding to " <> T.unpack _nc_dispatcher_bind
     _ <- bind s $ T.unpack _nc_dispatcher_bind
 
     tChan <- TChan.newTChanIO
@@ -81,7 +82,7 @@ dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions =
     -- NOTE I'm not sure that we need more than 1 worker here, but in
     -- theory, the worker can perform things like user authentication,
     -- DB queries etc so it can be slow sometimes.
-    Async.withAsync (throttle 500_000 throttleTChan sendDataMessageThrottled) $ \_ -> do
+    Async.withAsync (throttle 500_000 throttleTChan (sendDataMessageThrottled log_cfg)) $ \_ -> do
       void $ Async.concurrently (Async.replicateConcurrently 5 $ worker tChan throttleTChan) $ do
         forever $ do
           -- putText "[dispatcher_listener] receiving"
@@ -89,20 +90,22 @@ dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions =
           -- C.putStrLn $ "[dispatcher_listener] " <> r
           atomically $ TChan.writeTChan tChan r
   where
+    NotificationsConfig { _nc_dispatcher_bind } = config ^. gc_notifications_config
+    log_cfg = config ^. gc_logging
     worker tChan throttleTChan = do
       -- tId <- myThreadId
-      
+
       forever $ do
         r <- atomically $ TChan.readTChan tChan
         -- putText $ "[" <> show tId <> "] received a message: " <> decodeUtf8 r
-        
+
         case Aeson.decode (BSL.fromStrict r) of
           Nothing ->
-            withLogger () $ \ioL ->
+            withLogger log_cfg $ \ioL ->
               logMsg ioL DEBUG "[dispatcher_listener] unknown message from central exchange"
           Just ceMessage -> do
-            withLogger () $ \ioL ->
-              logMsg ioL DDEBUG $ "[dispatcher_listener] received " <> show ceMessage
+            withLogger log_cfg $ \ioL ->
+              logMsg ioL DEBUG $ "[dispatcher_listener] received " <> show ceMessage
             -- subs <- atomically $ readTVar subscriptions
             filteredSubs <- atomically $ do
               let subs' = UnfoldlM.filter (pure . ceMessageSubPred ceMessage) $ SSet.unfoldlM subscriptions
@@ -161,10 +164,10 @@ sendNotification throttleTChan ceMessage sub = do
 
 -- | The "true" message sending to websocket. After it was withheld
 -- for a while (for throttling), it is finally sent here
-sendDataMessageThrottled :: (WS.Connection, WS.DataMessage) -> IO ()
-sendDataMessageThrottled (conn, msg) = do
-  withLogger () $ \ioL ->
-    logMsg ioL DDEBUG $ "[sendDataMessageThrottled] dispatching notification: " <> show msg
+sendDataMessageThrottled :: LogConfig -> (WS.Connection, WS.DataMessage) -> IO ()
+sendDataMessageThrottled log_cfg (conn, msg) = do
+  withLogger log_cfg $ \ioL ->
+    logMsg ioL DEBUG $ "[sendDataMessageThrottled] dispatching notification: " <> show msg
   WS.sendDataMessage conn msg
 
 

src/Gargantext/Core/Notifications/Dispatcher/WebSocket.hs

@@ -11,13 +11,18 @@ https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
 
 Docs:
 https://dev.sub.gargantext.org/#/share/Notes/187918
-    
+
 -}
 
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}
-    
-module Gargantext.Core.Notifications.Dispatcher.WebSocket where
+
+module Gargantext.Core.Notifications.Dispatcher.WebSocket (
+  -- * Types
+    WSAPI(..)
+  -- * Functions
+  , wsServer
+  ) where
 
 import Control.Concurrent.Async qualified as Async
 import Control.Exception.Safe qualified as Exc
@@ -29,7 +34,7 @@ import Gargantext.API.Prelude (IsGargServer)
 import Gargantext.Core.Notifications.Dispatcher.Subscriptions
 import Gargantext.Core.Notifications.Dispatcher.Types
 import Gargantext.Core.Notifications.Dispatcher (Dispatcher, dispatcherSubscriptions)
-import Gargantext.Core.Config (HasJWTSettings(jwtSettings))
+import Gargantext.Core.Config (HasJWTSettings(jwtSettings), HasConfig (..), LogConfig, gc_logging)
 import Gargantext.Prelude
 import Gargantext.System.Logging (LogLevel(..), logMsg, withLogger, logM)
 import Network.WebSockets qualified as WS
@@ -39,7 +44,7 @@ import Servant.Auth.Server (JWTSettings, verifyJWT)
 import Servant.Server.Generic (AsServerT)
 import StmContainers.Set as SSet
 
-    
+
 newtype WSAPI mode = WSAPI {
     wsAPIServer :: mode :- "ws" :> Summary "WebSocket endpoint" :> WS.WebSocketPending
   } deriving Generic
@@ -55,12 +60,13 @@ wsServer = WSAPI { wsAPIServer = streamData }
                => WS.PendingConnection -> m ()
     streamData pc = Exc.catches (do
       jwtS <- view jwtSettings
+      log_cfg  <- view (hasConfig . gc_logging)
       d <- view hasDispatcher
       let subscriptions = dispatcherSubscriptions d
-      key <- getWSKey pc
+      key <- getWSKey log_cfg pc
       c <- liftBase $ WS.acceptRequest pc
       let ws = WSKeyConnection (key, c)
-      _ <- liftBase $ Async.concurrently (wsLoop jwtS subscriptions ws) (pingLoop ws)
+      _ <- liftBase $ Async.concurrently (wsLoop log_cfg jwtS subscriptions ws) (pingLoop ws)
       -- _ <- liftIO $ Async.withAsync (pure ()) (\_ -> wsLoop ws)
       pure ()
       ) [ Exc.Handler $ \(err :: WS.ConnectionException) ->
@@ -71,7 +77,7 @@ wsServer = WSAPI { wsAPIServer = streamData }
                 logM ERROR $ "[wsServer] error: " <> show err
                 Exc.throw err ]
 
-  
+
 -- | Send a ping control frame periodically, otherwise the
 -- | connection is dropped. NOTE that 'onPing' message is not
 -- | supported in the JS API: either the browser supports this or
@@ -84,17 +90,17 @@ pingLoop ws = do
     WS.sendPing (wsConn ws) ("" :: Text)
     threadDelay $ 10 * 1000000
 
-      
-wsLoop :: JWTSettings -> SSet.Set Subscription -> WSKeyConnection -> IO a
-wsLoop jwtS subscriptions ws = flip finally disconnect $ do
-  withLogger () $ \ioLogger -> do
+
+wsLoop :: LogConfig -> JWTSettings -> SSet.Set Subscription -> WSKeyConnection -> IO a
+wsLoop log_cfg jwtS subscriptions ws = flip finally disconnect $ do
+  withLogger log_cfg $ \ioLogger -> do
     logMsg ioLogger DEBUG "[wsLoop] connecting"
     wsLoop' CUPublic ioLogger
 
   where
     wsLoop' user ioLogger = do
       dm <- WS.receiveDataMessage (wsConn ws)
-      
+
       newUser <- case dm of
         WS.Text dm' _ -> do
           case Aeson.decode dm' of
@@ -132,25 +138,25 @@ wsLoop jwtS subscriptions ws = flip finally disconnect $ do
         _ -> do
           logMsg ioLogger DEBUG "[wsLoop] binary ws messages not supported"
           return user
-        
+
       wsLoop' newUser ioLogger
 
     disconnect = do
-      withLogger () $ \ioLogger -> do
+      withLogger log_cfg $ \ioLogger -> do
         logMsg ioLogger DEBUG "[wsLoop] disconnecting..."
         _ss <- removeSubscriptionsForWSKey subscriptions ws
         -- putText $ "[wsLoop] subscriptions: " <> show (show <$> ss)
         return ()
 
-    
-        
-getWSKey :: MonadBase IO m => WS.PendingConnection -> m ByteString
-getWSKey pc = do
+
+
+getWSKey :: MonadBase IO m => LogConfig -> WS.PendingConnection -> m ByteString
+getWSKey log_cfg pc = do
   let reqHead = WS.pendingRequest pc
   -- WebSocket specification says that a pending request should send
   -- some unique, Sec-WebSocket-Key string. We use this to compare
   -- connections (WS.Connection doesn't implement an Eq instance).
-  liftBase $ withLogger () $ \ioLogger -> do
+  liftBase $ withLogger log_cfg $ \ioLogger -> do
     logMsg ioLogger DEBUG $ "[wsLoop, getWSKey] headers: " <> show (WS.requestHeaders reqHead)
   let mKey = head $ filter (\(k, _) -> k == "Sec-WebSocket-Key") $ WS.requestHeaders reqHead
   let key' = snd $ fromMaybe (panicTrace "Sec-WebSocket-Key not found!") mKey

src/Gargantext/Core/Worker.hs

@@ -37,7 +37,7 @@ import Gargantext.API.Node.New (postNode')
 import Gargantext.API.Node.Update.Types (UpdateNodeParams(..), Granularity (..))
 import Gargantext.API.Node.Update (updateNode)
 import Gargantext.API.Server.Named.Ngrams (tableNgramsPostChartsAsync)
-import Gargantext.Core.Config (hasConfig, gc_database_config, gc_jobs, gc_notifications_config, gc_worker)
+import Gargantext.Core.Config (hasConfig, gc_database_config, gc_jobs, gc_worker, gc_logging)
 import Gargantext.Core.Config.Types (jc_max_docs_scrapers)
 import Gargantext.Core.Config.Worker (WorkerDefinition(..))
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
@@ -83,7 +83,7 @@ notifyJobStarted env (W.State { name }) bm = do
   let mId = messageId bm
   let j = toA $ getMessage bm
   let job = W.job j
-  withLogger () $ \ioL ->
+  withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
     logMsg ioL DEBUG $ "[notifyJobStarted] [" <> name <> " :: " <> show mId <> "] starting job: " <> show j
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
@@ -99,7 +99,7 @@ notifyJobFinished env (W.State { name }) bm = do
   let mId = messageId bm
   let j = toA $ getMessage bm
   let job = W.job j
-  withLogger () $ \ioL ->
+  withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
     logMsg ioL DEBUG $ "[notifyJobFinished] [" <> name <> " :: " <> show mId <> "] finished job: " <> show j
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
@@ -115,7 +115,7 @@ notifyJobTimeout env (W.State { name }) bm = do
   let mId = messageId bm
   let j = toA $ getMessage bm
   let job = W.job j
-  withLogger () $ \ioL ->
+  withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
     logMsg ioL ERROR $ "[notifyJobTimeout] [" <> name <> " :: " <> show mId <> "] job timed out: " <> show j
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
@@ -132,7 +132,7 @@ notifyJobFailed env (W.State { name }) bm exc = do
   let mId = messageId bm
   let j = toA $ getMessage bm
   let job = W.job j
-  withLogger () $ \ioL ->
+  withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
     logMsg ioL ERROR $ "[notifyJobFailed] [" <> name <> " :: " <> show mId <> "] failed job: " <> show j <> "   --- ERROR: " <> show exc
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
@@ -148,7 +148,7 @@ notifyJobKilled _ _ Nothing = pure ()
 notifyJobKilled env (W.State { name }) (Just bm) = do
   let j = toA $ getMessage bm
   let job = W.job j
-  withLogger () $ \ioL ->
+  withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
     logMsg ioL ERROR $ "[notifyJobKilled] [" <> name <> "] failed job: " <> show j
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
@@ -213,33 +213,33 @@ performAction env _state bm = do
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
   let jh = WorkerJobHandle { _w_job_info = ji }
-  
+
   case job of
     Ping -> runWorkerMonad env $ do
       $(logLocM) DEBUG "[performAction] ping"
-      liftIO $ CE.notify (env ^. (to _w_env_config) . gc_notifications_config) CET.Ping
-      
+      liftIO $ CE.notify (env ^. (to _w_env_config)) CET.Ping
+
     -- | flow action for a single contact
     AddContact { .. } -> runWorkerMonad env $ do
       $(logLocM) DEBUG $ "[performAction] add contact"
       addContact _ac_user _ac_node_id _ac_args jh
-      
+
     -- | Send a file with documents and index them in corpus
     AddCorpusFormAsync { .. } -> runWorkerMonad env $ do
       $(logLocM) DEBUG $ "[performAction] add corpus form"
       addToCorpusWithForm _acf_user _acf_cid _acf_args jh
-      
+
     -- | Perform external API search query and index documents in corpus
     AddCorpusWithQuery { .. } -> runWorkerMonad env $ do
       $(logLocM) DEBUG "[performAction] add corpus with query"
       let limit = Just $ fromIntegral $ env ^. hasConfig . gc_jobs . jc_max_docs_scrapers
       addToCorpusWithQuery _acq_user _acq_cid _acq_args limit jh
-      
+
     -- | Add to annuaire, from given file (not implemented yet)
     AddToAnnuaireWithForm { .. } -> runWorkerMonad env $ do
       $(logLocM) DEBUG "[performAction] add to annuaire with form"
       Annuaire.addToAnnuaireWithForm _aawf_annuaire_id _aawf_args jh
-      
+
     -- | Saves file to 'data_filepath' (in TOML), adds this file as a node
     AddWithFile { .. } -> runWorkerMonad env $ do
       $(logLocM) DEBUG "[performAction] add with file"

src/Gargantext/Core/Worker/Env.hs

@@ -10,6 +10,7 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans      #-}  -- orphan HasNodeError IOException
 
@@ -19,6 +20,7 @@ module Gargantext.Core.Worker.Env where
 
 import Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVarIO, readTVarIO)
 import Control.Lens (prism', to, view)
+import Control.Lens.TH
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Maybe (fromJust)
 import Data.Pool qualified as Pool
@@ -30,7 +32,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(..))
+import Gargantext.Core.Config (GargConfig(..), HasConfig(..), gc_logging)
 import Gargantext.Core.Config.Mail qualified as Mail
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Config.Types (SettingsFile(..))
@@ -43,7 +45,7 @@ import Gargantext.Database.Prelude (HasConnectionPool(..))
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Database.Query.Tree.Error (HasTreeError(..))
 import Gargantext.Prelude hiding (to)
-import Gargantext.System.Logging (HasLogger(..), Logger, LogLevel(..), MonadLogger(..), withLogger, logMsg, withLoggerHoisted)
+import Gargantext.System.Logging (HasLogger(..), Logger, LogLevel(..), MonadLogger(..), withLogger, logMsg, withLoggerIO)
 import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
 import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))
 import Prelude qualified
@@ -68,7 +70,7 @@ data WorkerJobState = WorkerJobState
 
 
 withWorkerEnv :: SettingsFile -> (WorkerEnv -> IO a) -> IO a
-withWorkerEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
+withWorkerEnv settingsFile k = withLoggerIO Dev $ \logger -> do
   env <- newWorkerEnv logger
   k env -- `finally` cleanEnv env
 
@@ -137,9 +139,9 @@ instance CET.HasCentralExchangeNotification WorkerEnv where
   ce_notify m = do
     c <- asks (view $ to _w_env_config)
     liftBase $ do
-      withLogger () $ \ioL ->
-        logMsg ioL DDEBUG $ "[ce_notify]: " <> show (_gc_notifications_config c) <> " :: " <> show m
-      CE.notify (_gc_notifications_config c) m
+      withLogger (c ^. gc_logging) $ \ioL ->
+        logMsg ioL DEBUG $ "[ce_notify]: " <> show (_gc_notifications_config c) <> " :: " <> show m
+      CE.notify c m
 
 ---------
 instance HasValidationError IOException where
@@ -236,7 +238,7 @@ instance MonadJobStatus WorkerMonad where
                              Nothing -> jobLogFailures steps latest
                              Just msg -> addErrorEvent msg (jobLogFailures steps latest))
   markComplete jh       = updateJobProgress jh jobLogComplete
-  markFailed mb_msg jh  = 
+  markFailed mb_msg jh  =
     updateJobProgress jh (\latest -> case mb_msg of
                              Nothing -> jobLogFailTotal latest
                              Just msg -> jobLogFailTotalWithMessage msg latest)
@@ -264,4 +266,6 @@ updateJobProgress (WorkerJobHandle (ji@JobInfo { _ji_message_id })) f = do
         in
       Just (WorkerJobState { _wjs_job_info = ji
                            , _wjs_job_log = f initJobLog })
-    
+
+
+makeLenses ''WorkerEnv

src/Gargantext/Core/Worker/Jobs.hs

@@ -15,7 +15,7 @@ module Gargantext.Core.Worker.Jobs where
 
 import Async.Worker qualified as W
 import Control.Lens (view)
-import Gargantext.Core.Config (gc_database_config, gc_worker, HasConfig(..), GargConfig)
+import Gargantext.Core.Config (gc_database_config, gc_worker, HasConfig(..), GargConfig, gc_logging)
 import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
 import Gargantext.Core.Worker.Broker (initBrokerWithDBCreate)
 import Gargantext.Core.Worker.Jobs.Types (Job(..))
@@ -44,7 +44,7 @@ sendJobWithCfg gcConfig job = do
       b <- initBrokerWithDBCreate (gcConfig ^. gc_database_config) ws
       let queueName = _wdQueue wd
       let job' = (updateJobData job $ W.mkDefaultSendJob' b queueName job) { W.delay = _wsDefaultDelay }
-      withLogger () $ \ioL ->
+      withLogger (gcConfig ^. gc_logging) $ \ioL ->
         logMsg ioL DEBUG $ "[sendJob] sending job " <> show job <> " (delay " <> show (W.delay job') <> ")"
       W.sendJob' job'
 

src/Gargantext/System/Logging.hs

-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies    #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeApplications     #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Gargantext.System.Logging (
-    LogLevel(..)
-  , HasLogger(..)
-  , MonadLogger(..)
+    module Gargantext.System.Logging.Types
   , logM
   , logLocM
   , logLoc
   , withLogger
-  , withLoggerHoisted
+  , withLoggerIO
   ) where
 
+import Gargantext.System.Logging.Types
 import Control.Exception.Safe (MonadMask, bracket)
 import Control.Monad (when)
+import Gargantext.Core.Config (LogConfig(..))
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Control
-import Data.Kind (Type)
 import Data.Text qualified as T
 import Data.Time.Clock (getCurrentTime)
 import Language.Haskell.TH hiding (Type)
 import Language.Haskell.TH.Syntax qualified as TH
 import Prelude
 import System.Environment (lookupEnv)
-import Text.Read (readMaybe)
 
 
-data LogLevel =
-  -- | Detailed debug messages
-  DDEBUG
-  -- | Debug messages
-  | DEBUG
-  -- | Information
-  | INFO
-  -- | Normal runtime conditions
-  | NOTICE
-  -- | General Warnings
-  | WARNING
-  -- | General Errors
-  | ERROR
-  -- | Severe situations
-  | CRITICAL
-  -- | Take immediate action
-  | ALERT
-  -- | System is unusable
-  | EMERGENCY
-  deriving (Show, Eq, Ord, Enum, Bounded, Read)
-
--- | This is a barebore logging interface which we
--- can extend to plug a proper logging library, without
--- the details of the logger cropping up everywhere in
--- the rest of the codebase.
-class HasLogger m where
-  data family Logger m        :: Type
-  type family LogInitParams m :: Type
-  type family LogPayload m    :: Type
-  initLogger    :: LogInitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
-  destroyLogger :: Logger m        -> (forall m1. MonadIO m1 => m1 ())
-  logMsg        :: Logger m        -> LogLevel -> LogPayload m -> m ()
-  logTxt        :: Logger m        -> LogLevel -> T.Text -> m ()
-
--- | Separate typeclass to get hold of a 'Logger' from within a monad.
--- We keey 'HasLogger' and 'MonadLogger' separate to enforce compositionality,
--- i.e. we can still give instances to 'HasLogger' for things like 'IO' without
--- having to force actually acquiring a logger for those monads.
-class HasLogger m => MonadLogger m where
-  getLogger :: m (Logger m)
-
 -- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
 logM :: (Monad m, MonadLogger m) => LogLevel -> T.Text -> m ()
 logM level msg = do
@@ -119,26 +77,29 @@ withLogger params = bracket (initLogger params) destroyLogger
 
 -- | Like 'withLogger', but it allows creating a 'Logger' that can run in
 -- a different monad from within an 'IO' action.
-withLoggerHoisted :: (MonadBaseControl IO m, HasLogger m)
-                  => LogInitParams m
-                  -> (Logger m -> IO a)
-                  -> IO a
-withLoggerHoisted params act = bracket (initLogger params) destroyLogger act
+withLoggerIO :: (MonadBaseControl IO m, HasLogger m)
+             => LogInitParams m
+             -> (Logger m -> IO a)
+             -> IO a
+withLoggerIO params act = bracket (initLogger params) destroyLogger act
 
 -- | A plain logger in the IO monad, waiting for more serious logging solutions like
 -- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
 instance HasLogger IO where
   data instance Logger IO        = IOLogger LogLevel
-  type instance LogInitParams IO = ()
+  type instance LogInitParams IO = LogConfig
   type instance LogPayload IO    = String
-  initLogger () = do
-    mLvl <- liftIO $ lookupEnv "LOG_LEVEL"
-    let lvl = case mLvl of
-          Nothing      -> INFO
+  initLogger LogConfig{..} = do
+    -- let the env var take precedence over the LogConfig one.
+    mLvl <- liftIO $ lookupEnv "GGTX_LOG_LEVEL"
+    lvl <- case mLvl of
+          Nothing      -> pure _lc_log_level
           Just s       ->
-            case readMaybe s of
-              Nothing -> error $ "unknown log level " <> s
-              Just lvl' -> lvl'
+            case parseLogLevel (T.pack s) of
+              Left err   -> do
+                liftIO $ putStrLn $ "unknown log level " <> s <> ": " <> T.unpack err <> " , ignoring GGTX_LOG_LEVEL"
+                pure $ _lc_log_level
+              Right lvl' -> pure lvl'
     pure $ IOLogger lvl
   destroyLogger _ = pure ()
   logMsg (IOLogger minLvl) lvl msg = do

src/Gargantext/System/Logging/Types.hs

+{-# LANGUAGE TypeFamilies  #-}
+{-# LANGUAGE LambdaCase    #-}
+
+module Gargantext.System.Logging.Types (
+    LogLevel(..)
+  , HasLogger(..)
+  , MonadLogger(..)
+  , parseLogLevel
+  , renderLogLevel
+  , prop_loglevel_roundtrip
+  ) where
+
+import Control.Monad.IO.Class
+import Data.Kind (Type)
+import Data.Text qualified as T
+import Prelude
+
+
+data LogLevel =
+  -- | Debug messages
+    DEBUG
+  -- | Information
+  | INFO
+  -- | Normal runtime conditions
+  | WARNING
+  -- | General Errors
+  | ERROR
+  deriving (Show, Eq, Ord, Enum, Bounded, Read)
+
+renderLogLevel :: LogLevel -> T.Text
+renderLogLevel = \case
+  DEBUG   -> "debug"
+  INFO    -> "info"
+  WARNING -> "warning"
+  ERROR   -> "error"
+
+parseLogLevel :: T.Text -> Either T.Text LogLevel
+parseLogLevel = \case
+  "debug"   -> Right DEBUG
+  "info"    -> Right INFO
+  "warning" -> Right WARNING
+  "warn"    -> Right WARNING
+  "error"   -> Right ERROR
+  xs -> Left ("Invalid log level found: " <> xs)
+
+prop_loglevel_roundtrip :: LogLevel -> Bool
+prop_loglevel_roundtrip ll = (parseLogLevel . renderLogLevel $ ll) == Right ll
+
+-- | This is a barebore logging interface which we
+-- can extend to plug a proper logging library, without
+-- the details of the logger cropping up everywhere in
+-- the rest of the codebase.
+class HasLogger m where
+  data family Logger m        :: Type
+  type family LogInitParams m :: Type
+  type family LogPayload m    :: Type
+  initLogger    :: LogInitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
+  destroyLogger :: Logger m        -> (forall m1. MonadIO m1 => m1 ())
+  logMsg        :: Logger m        -> LogLevel -> LogPayload m -> m ()
+  logTxt        :: Logger m        -> LogLevel -> T.Text -> m ()
+
+-- | Separate typeclass to get hold of a 'Logger' from within a monad.
+-- We keey 'HasLogger' and 'MonadLogger' separate to enforce compositionality,
+-- i.e. we can still give instances to 'HasLogger' for things like 'IO' without
+-- having to force actually acquiring a logger for those monads.
+class HasLogger m => MonadLogger m where
+  getLogger :: m (Logger m)

test-data/test_config.toml

@@ -52,6 +52,10 @@ user = "gargantua"
 pass = "gargantua_test"
 name = "gargandb_test"
 
+[logs]
+log_file = "/var/log/gargantext/backend.log"
+log_level = "warn"
+
 [mail]
 port = 25
 host = "localhost"

test/Test/API/Notifications.hs

@@ -14,24 +14,24 @@ Portability : POSIX
 {-# LANGUAGE QuasiQuotes      #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-    
+
 module Test.API.Notifications (
     tests
   ) where
 
-import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM.TChan
 import Control.Concurrent.STM.TSem (newTSem, signalTSem, TSem)
+import Control.Concurrent (threadDelay)
 import Control.Lens ((^.))
-import Control.Monad (void)
 import Control.Monad.STM (atomically)
+import Control.Monad (void)
 import Data.Aeson qualified as Aeson
 import Data.ByteString qualified as BS
-import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
+import Data.Text qualified as T
 import Fmt ((+|), (|+))
 import Gargantext.API.Admin.Auth.Types (AuthResponse, authRes_token, authRes_tree_id)
-import Gargantext.Core.Config (gc_notifications_config)
+import Gargantext.Core.Config (gc_logging, LogConfig)
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
 import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
 import Gargantext.Core.Notifications.Dispatcher.Types qualified as DT
@@ -47,9 +47,9 @@ import Test.Database.Types (test_config)
 import Test.Hspec
 import Test.Hspec.Wai.Internal (withApplication)
 import Test.Instances ()
-import Text.RawString.QQ (r)
-import Test.Utils (protected, waitForTChanValue, waitForTSem, withValidLoginA)
 import Test.Utils.Notifications (withAsyncWSConnection)
+import Test.Utils (protected, waitForTChanValue, waitForTSem, withValidLoginA)
+import Text.RawString.QQ (r)
 
 
 
@@ -57,10 +57,11 @@ tests :: Spec
 tests = sequential $ around withTestDBAndPort $ do
   describe "Notifications" $ do
     it "ping WS notification works" $ \(SpecContext testEnv port _app _) -> do
-      let nc = (test_config testEnv) ^. gc_notifications_config
+      let cfg     = test_config testEnv
+      let log_cfg = (test_config testEnv) ^. gc_logging
       -- withLogger () $ \ioL -> do
       --   logMsg ioL DEBUG $ "[ping WS notification works] nc: " <> show nc
-      
+
       let topic = DT.Ping
       -- This semaphore is used to inform the main thread that the WS
       -- client has subscribed. I think it's better to use async
@@ -68,34 +69,35 @@ tests = sequential $ around withTestDBAndPort $ do
       wsTSem <- atomically $ newTSem 0
       tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
 
-      withAsyncWSConnection ("127.0.0.1", port) (wsConnection topic wsTSem tchan) $ \_a -> do
+      withAsyncWSConnection ("127.0.0.1", port) (wsConnection log_cfg topic wsTSem tchan) $ \_a -> do
         -- wait for ws process to inform us about topic subscription
         waitForTSem wsTSem 500
-        
+
         threadDelay 300_000
-        CE.notify nc $ CET.Ping
+        CE.notify cfg $ CET.Ping
 
         -- the ping value that should come from the notification
         waitForTChanValue tchan (Just DT.NPing) 1_000
 
     it "ping WS unsubscribe works" $ \(SpecContext testEnv port _app _) -> do
-      let nc = (test_config testEnv) ^. gc_notifications_config      
+      let cfg     = test_config testEnv
+      let log_cfg = (test_config testEnv) ^. gc_logging
       let topic = DT.Ping
 
       -- Setup a WS client connection. Subscribe to a topic and
       -- confirm the notification works. Then unsubscribe from it, and
       -- check that a new notification didn't arrive.
-      
+
       wsTSem <- atomically $ newTSem 0
       tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
-      
+
       -- setup a websocket connection
-      let wsConnect conn = withLogger () $ \_ioL -> do
+      let wsConnect conn = withLogger log_cfg $ \_ioL -> do
             -- logMsg ioL DEBUG $ "[wsConnect] subscribing topic: " <> show topic
             WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe topic)
             -- inform the test process that we sent the subscription request
             atomically $ signalTSem wsTSem
-            
+
             -- logMsg ioL DEBUG $ "[wsConnect] waiting for notification"
             d <- WS.receiveData conn
             -- logMsg ioL DEBUG $ "[wsConnect] received " <> show d
@@ -116,13 +118,13 @@ tests = sequential $ around withTestDBAndPort $ do
               Nothing -> atomically $ writeTChan tchan Nothing
               -- | write something incorrect so the test will fail
               Just _ -> atomically $ writeTChan tchan (Just DT.NPing)
-            
+
       withAsyncWSConnection ("127.0.0.1", port) wsConnect $ \_a -> do
         -- wait for ws process to inform us about topic subscription
         waitForTSem wsTSem 500
-        
+
         threadDelay 300_000
-        CE.notify nc $ CET.Ping
+        CE.notify cfg $ CET.Ping
 
         -- the ping value that should come from the notification
         waitForTChanValue tchan (Just DT.NPing) 1_000
@@ -130,26 +132,24 @@ tests = sequential $ around withTestDBAndPort $ do
         -- wait for lock from ws (it should have unsubscribed by now)
         waitForTSem wsTSem 500
         -- send the notification (which the client shouldn't receive)
-        CE.notify nc $ CET.Ping
+        CE.notify cfg $ CET.Ping
         -- wait for the value
         waitForTChanValue tchan Nothing 1_000
-    
+
     describe "Update tree notifications" $ do
       it "simple WS notification works" $ \(SpecContext testEnv port _app _) -> do
-        let nc = (test_config testEnv) ^. gc_notifications_config
-        
         let topic = DT.UpdateTree 0
         wsTSem <- atomically $ newTSem 0  -- initially locked
         tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
-  
-        withAsyncWSConnection ("127.0.0.1", port) (wsConnection topic wsTSem tchan) $ \_a -> do
+
+        withAsyncWSConnection ("127.0.0.1", port) (wsConnection (test_config testEnv ^. gc_logging) topic wsTSem tchan) $ \_a -> do
           waitForTSem wsTSem 500
-          
+
           let nodeId = 0
-          CE.notify nc $ CET.UpdateTreeFirstLevel nodeId
-  
+          CE.notify (test_config testEnv) $ CET.UpdateTreeFirstLevel nodeId
+
           waitForTChanValue tchan (Just $ DT.NUpdateTree nodeId) 1_000
-      
+
       it "WS notification on node creation works" $ \ctx@(SpecContext _testEnv port app _) -> do
         checkNotification ctx $ \authRes -> do
           let token = authRes ^. authRes_token
@@ -157,20 +157,20 @@ tests = sequential $ around withTestDBAndPort $ do
           let query = [r| {"pn_name": "test", "pn_typename": "NodeCorpus"} |]
           void $ withApplication app $ do
             protected token "POST" (mkUrl port $ "/node/" +| treeId |+ "") query
-  
+
       it "WS notification on node deletion works" $ \ctx@(SpecContext testEnv port app _) -> do
         checkNotification ctx $ \authRes -> do
           let token = authRes ^. authRes_token
           cId <- newCorpusForUser testEnv "alice"
-            
+
           void $ withApplication app $ do
             protected token "DELETE" (mkUrl port $ "/node/" +| cId |+ "") ""
-  
+
       it "WS notification on node rename works" $ \ctx@(SpecContext testEnv port app _) -> do
         checkNotification ctx $ \authRes -> do
           let token = authRes ^. authRes_token
           cId <- newCorpusForUser testEnv "alice"
-          
+
           void $ withApplication app $ do
             let query = [r| {"name": "newName"} |]
             protected token "PUT" (mkUrl port $ "/node/" +| cId |+ "/rename") query
@@ -180,7 +180,7 @@ tests = sequential $ around withTestDBAndPort $ do
           let token = authRes ^. authRes_token
           cId <- newCorpusForUser testEnv "alice"
           cId2 <- newCorpusForUser testEnv "alice"
-          
+
           void $ withApplication app $ do
             let query = BS.fromStrict $ TE.encodeUtf8 $ "[" <> (T.pack $ show cId2) <> "]"
             protected token "PUT" (mkUrl port $ "/node/" +| cId |+ "/move/" +| cId2 |+ "" ) query
@@ -193,9 +193,9 @@ tests = sequential $ around withTestDBAndPort $ do
 checkNotification :: SpecContext a
                   -> (AuthResponse -> IO ())
                   -> IO ()
-checkNotification ctx@(SpecContext _testEnv port _app _) act = do
+checkNotification ctx@(SpecContext testEnv port _app _) act = do
   _ <- dbEnvSetup ctx
-  
+
   withValidLoginA port "alice" (GargPassword "alice") $ \_clientEnv authRes -> do
     -- Subscribe to user tree notifications
     let treeId = authRes ^. authRes_tree_id
@@ -204,26 +204,28 @@ checkNotification ctx@(SpecContext _testEnv port _app _) act = do
     wsTSem <- atomically $ newTSem 0  -- initially locked
     tchan <- newTChanIO :: IO (TChan (Maybe DT.Notification))
 
-    withAsyncWSConnection ("127.0.0.1", port) (wsConnection topic wsTSem tchan) $ \_a -> do
+    withAsyncWSConnection ("127.0.0.1", port) (wsConnection log_cfg topic wsTSem tchan) $ \_a -> do
       waitForTSem wsTSem 500
 
       act authRes
-  
-      waitForTChanValue tchan (Just $ DT.NUpdateTree treeId) 1_000
 
+      waitForTChanValue tchan (Just $ DT.NUpdateTree treeId) 1_000
+  where
+    log_cfg = (test_config testEnv) ^. gc_logging
 
 
-wsConnection :: DT.Topic
+wsConnection :: LogConfig
+             -> DT.Topic
              -> TSem
              -> TChan (Maybe DT.Notification)
              -> WS.Connection
              -> IO ()
-wsConnection topic wsTSem tchan conn = withLogger () $ \_ioL -> do
+wsConnection log_cfg topic wsTSem tchan conn = withLogger log_cfg $ \_ioL -> do
   -- logMsg ioL DEBUG $ "[wsConnect] subscribing topic: " <> show topic
   WS.sendTextData conn $ Aeson.encode (DT.WSSubscribe topic)
   -- inform the test process that we sent the subscription request
   atomically $ signalTSem wsTSem
-  
+
   -- logMsg ioL DEBUG $ "[wsConnect] waiting for notification"
   d <- WS.receiveData conn
   -- logMsg ioL DEBUG $ "[wsConnect] received " <> show d

test/Test/API/Private/Remote.hs

@@ -32,10 +32,10 @@ withTwoServerInstances :: (SpecContext (TestEnv,Wai.Application,Warp.Port) -> IO
 withTwoServerInstances action =
   withTestDB $ \testEnv1 -> do
     withTestDB $ \testEnv2 -> do
-      garg1App <- withLoggerHoisted Mock $ \ioLogger -> do
+      garg1App <- withLoggerIO Mock $ \ioLogger -> do
                    env <- newTestEnv testEnv1 ioLogger server1Port
                    makeApp env
-      garg2App <- withLoggerHoisted Mock $ \ioLogger -> do
+      garg2App <- withLoggerIO Mock $ \ioLogger -> do
                    env <- newTestEnv testEnv2 ioLogger server2Port
                    makeApp env
 

test/Test/API/Setup.hs

@@ -20,13 +20,15 @@ import Control.Monad.Reader
 import Data.ByteString.Lazy.Char8 qualified as C8L
 import Data.Cache qualified as InMemory
 import Data.Streaming.Network (bindPortTCP)
-import Gargantext.API (makeApp)
 import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..), env_dispatcher)
 import Gargantext.API.Errors.Types
+import Gargantext.API (makeApp)
 import Gargantext.API.Prelude
-import Gargantext.Core.Notifications (withNotifications)
+import Gargantext.Core.Config (gc_logging)
+import Gargantext.Core.Config (gc_notifications_config)
 import Gargantext.Core.Config (_gc_secrets, gc_frontend_config)
 import Gargantext.Core.Config.Types (NotificationsConfig(..), fc_appPort, jwtSettings)
+import Gargantext.Core.Notifications (withNotifications)
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.Flow
 import Gargantext.Database.Action.User.New
@@ -44,10 +46,10 @@ import Network.HTTP.Client.TLS (newTlsManager)
 import Network.HTTP.Types
 import Network.Wai (Application, responseLBS)
 import Network.Wai.Handler.Warp.Internal
-import Network.WebSockets qualified as WS
 import Network.Wai.Handler.Warp qualified as Warp
 import Network.Wai.Handler.Warp (runSettingsSocket)
 import Network.Wai qualified as Wai
+import Network.WebSockets qualified as WS
 import Prelude hiding (show)
 import Servant.Auth.Client ()
 import Test.Database.Setup (withTestDB)
@@ -108,9 +110,9 @@ nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560"
 -- | Run the gargantext server on a random port, picked by Warp, which allows
 -- for concurrent tests to be executed in parallel, if we need to.
 withTestDBAndPort :: (SpecContext () -> IO ()) -> IO ()
-withTestDBAndPort action = withNotifications nc $ \dispatcher -> do
-  withTestDB $ \testEnv -> do    
-    withLoggerHoisted Mock $ \ioLogger -> do
+withTestDBAndPort action = withTestDB $ \testEnv -> do
+  withNotifications (cfg testEnv) $ \dispatcher -> do
+    withLoggerIO Mock $ \ioLogger -> do
       env <- newTestEnv testEnv ioLogger 8080
              <&> env_dispatcher .~ dispatcher
       app <- makeApp env
@@ -124,30 +126,32 @@ withTestDBAndPort action = withNotifications nc $ \dispatcher -> do
         [ Handler $ \(err :: WS.ConnectionException) ->
             case err of
               WS.CloseRequest _ _ ->
-                withLogger () $ \ioLogger' ->
+                withLogger (log_cfg testEnv) $ \ioLogger' ->
                   logTxt ioLogger' DEBUG "[withTestDBAndPort] CloseRequest caught"
               WS.ConnectionClosed ->
-                withLogger () $ \ioLogger' ->
+                withLogger (log_cfg testEnv) $ \ioLogger' ->
                   logTxt ioLogger' DEBUG "[withTestDBAndPort] ConnectionClosed caught"
               _ -> do
-                withLogger () $ \ioLogger' ->
+                withLogger (log_cfg testEnv) $ \ioLogger' ->
                   logTxt ioLogger' ERROR $ "[withTestDBAndPort] unknown exception: " <> show err
                 throw err
-        
+
         -- re-throw any other exceptions
         , Handler $ \(err :: SomeException) -> throw err ]
-        
+  where
+    cfg te     = (test_config te) & gc_notifications_config .~ nc
+    log_cfg te = (cfg te) ^. gc_logging
 
 -- | Starts the backend server /and/ the microservices proxy, the former at
 -- a random port, the latter at a predictable port.
 withBackendServerAndProxy :: (((TestEnv, Warp.Port, Warp.Port)) -> IO ()) -> IO ()
 withBackendServerAndProxy action =
   withTestDB $ \testEnv -> do
-    gargApp <- withLoggerHoisted Mock $ \ioLogger -> do
+    gargApp <- withLoggerIO Mock $ \ioLogger -> do
                  env <- newTestEnv testEnv ioLogger 8080
                  makeApp env
     proxyCache <- InMemory.newCache Nothing
-    proxyApp <- withLoggerHoisted Mock $ \ioLogger -> do
+    proxyApp <- withLoggerIO Mock $ \ioLogger -> do
                   env <- newTestEnv testEnv ioLogger 8080
                   pure $ microServicesProxyApp proxyCache env
 
@@ -186,7 +190,7 @@ dbEnvSetup ctx = do
   _ <- createAliceAndBob testEnv
 
   pure ctx
-  
+
 -- show the full exceptions during testing, rather than shallowing them under a generic
 -- "Something went wrong".
 showDebugExceptions :: SomeException -> Wai.Response

test/Test/API/UpdateList.hs

@@ -27,21 +27,21 @@ module Test.API.UpdateList (
 
 import Control.Lens (mapped, over)
 import Control.Monad.Fail (fail)
-import Data.Aeson qualified as JSON
 import Data.Aeson.QQ
+import Data.Aeson qualified as JSON
 import Data.ByteString.Lazy qualified as BSL
-import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
+import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
-import Data.Text qualified as T
 import Data.Text.IO qualified as TIO
+import Data.Text qualified as T
 import Fmt
 import Gargantext.API.Admin.Auth.Types (Token)
 import Gargantext.API.Errors
 import Gargantext.API.HashedResponse
-import Gargantext.API.Ngrams qualified as APINgrams
 import Gargantext.API.Ngrams.List ( ngramsListFromTSVData )
 import Gargantext.API.Ngrams.List.Types (WithJsonFile(..), WithTextFile(..))
+import Gargantext.API.Ngrams qualified as APINgrams
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Node.Corpus.New.Types qualified as FType
 import Gargantext.API.Node.Types
@@ -50,6 +50,7 @@ import Gargantext.API.Routes.Named.Corpus
 import Gargantext.API.Routes.Named.Node
 import Gargantext.API.Routes.Named.Private
 import Gargantext.API.Worker (workerAPIPost)
+import Gargantext.Core.Config
 import Gargantext.Core qualified as Lang
 import Gargantext.Core.Text.Corpus.Query (RawQuery(..))
 import Gargantext.Core.Text.List.Social
@@ -62,6 +63,7 @@ import Gargantext.Database.Query.Facet qualified as Facet
 import Gargantext.Prelude hiding (get)
 import Network.Wai.Handler.Warp qualified as Wai
 import Paths_gargantext (getDataFileName)
+import qualified Prelude
 import Servant.Client.Streaming
 import System.FilePath
 import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser)
@@ -74,16 +76,16 @@ import Test.Hspec.Wai.JSON (json)
 import Test.Types (JobPollHandle(..))
 import Test.Utils (pollUntilWorkFinished, protectedJSON, withValidLogin)
 import Text.Printf (printf)
-import qualified Prelude
 
 
-uploadJSONList :: Wai.Port
+uploadJSONList :: LogConfig
+               -> Wai.Port
                -> Token
                -> CorpusId
                -> FilePath
                -> ClientEnv
                -> WaiSession () ListId
-uploadJSONList port token cId pathToNgrams clientEnv = do
+uploadJSONList log_cfg port token cId pathToNgrams clientEnv = do
   ([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
   -- Upload the JSON doc
   simpleNgrams' <- liftIO (TIO.readFile =<< getDataFileName pathToNgrams)
@@ -100,7 +102,7 @@ uploadJSONList port token cId pathToNgrams clientEnv = do
   -- j' <- pollUntilFinished token port mkPollUrl j
   ji <- checkEither $ liftIO $ runClientM (add_form_to_list token listId params) clientEnv
   -- liftIO (_jph_status j' `shouldBe` "IsFinished")
-  ji' <- pollUntilWorkFinished port ji
+  ji' <- pollUntilWorkFinished log_cfg port ji
   liftIO $ ji' `shouldBe` ji
   
   pure listId
@@ -115,9 +117,10 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
 
       it "allows uploading a JSON ngrams file" $ \(SpecContext testEnv port app _) -> do
         cId <- newCorpusForUser testEnv "alice"
+        let log_cfg = (test_config testEnv) ^. gc_logging
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
-            listId <- uploadJSONList port token cId "test-data/ngrams/simple.json" clientEnv
+            listId <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
 
             -- Now check that we can retrieve the ngrams
             liftIO $ do
@@ -139,6 +142,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
 
       it "does not create duplicates when uploading JSON (#313)" $ \(SpecContext testEnv port app _) -> do
         cId <- newCorpusForUser testEnv "alice"
+        let log_cfg = (test_config testEnv) ^. gc_logging
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
             -- this term is imported from the .json file
@@ -146,7 +150,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
             -- this is the new term, under which importedTerm will be grouped
             let newTerm = NgramsTerm "new abelian group"
 
-            listId <- uploadJSONList port token cId "test-data/ngrams/simple.json" clientEnv
+            listId <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
 
             let checkNgrams expected = do
                   eng <- liftIO $ runClientM (get_table_ngrams token cId APINgrams.Terms listId 10 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
@@ -187,7 +191,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
             -- finally, upload the list again, the group should be as
             -- it was before (the bug in #313 was that "abelian group"
             -- was created again as a term with no parent)
-            _ <- uploadJSONList port token cId "test-data/ngrams/simple.json" clientEnv
+            _ <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
 
             -- old (imported) term shouldn't become parentless
             -- (#313 error was that we had [newTerm, importedTerm] instead)
@@ -211,6 +215,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
 
       it "allows uploading a CSV ngrams file" $ \(SpecContext testEnv port app _) -> do
         cId <- newCorpusForUser testEnv "alice"
+        let log_cfg = (test_config testEnv) ^. gc_logging
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
             ([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
@@ -220,7 +225,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
                                       , _wtf_data = simpleNgrams
                                       , _wtf_name = "simple.tsv" }
             ji <- checkEither $ liftIO $ runClientM (add_tsv_to_list token listId params) clientEnv
-            _ <- pollUntilWorkFinished port ji
+            _ <- pollUntilWorkFinished log_cfg port ji
 
             -- Now check that we can retrieve the ngrams
             liftIO $ do
@@ -258,6 +263,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
             void $ createFortranDocsList testEnv port clientEnv token
 
       it "doesn't use trashed documents for score calculation (#385)" $ \(SpecContext testEnv port app _) -> do
+        let log_cfg = (test_config testEnv) ^. gc_logging
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
             corpusId <- createFortranDocsList testEnv port clientEnv token
@@ -276,7 +282,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
               pure tr1
 
 
-            termsNodeId <- uploadJSONList port token corpusId "test-data/ngrams/GarganText_NgramsTerms-nodeId-177.json" clientEnv
+            termsNodeId <- uploadJSONList log_cfg port token corpusId "test-data/ngrams/GarganText_NgramsTerms-nodeId-177.json" clientEnv
 
             liftIO $ do
               -- Now let's check the score for the \"fortran\" ngram.
@@ -344,19 +350,26 @@ createDocsList testDataPath testEnv port clientEnv token = do
   simpleDocs <- liftIO (TIO.readFile =<< getDataFileName testDataPath)
   let newWithForm = mkNewWithForm simpleDocs (T.pack $ takeBaseName testDataPath)
   ji <- checkEither $ liftIO $ runClientM (add_file_async token corpusId newWithForm) clientEnv
-  ji' <- pollUntilWorkFinished port ji
+  ji' <- pollUntilWorkFinished log_cfg port ji
   liftIO $ ji' `shouldBe` ji
   pure corpusId
+  where
+    log_cfg = (test_config testEnv) ^. gc_logging
 
 createFortranDocsList :: TestEnv -> Int -> ClientEnv -> Token -> WaiSession () CorpusId
 createFortranDocsList testEnv port =
   createDocsList "test-data/ngrams/GarganText_DocsList-nodeId-177.json" testEnv port
 
-updateNode :: Int -> ClientEnv -> Token -> NodeId -> WaiSession () ()
-updateNode port clientEnv token nodeId = do
+updateNode :: LogConfig
+           -> Int
+           -> ClientEnv
+           -> Token
+           -> NodeId
+           -> WaiSession () ()
+updateNode log_cfg port clientEnv token nodeId = do
   let params = UpdateNodeParamsTexts Both
   ji <- checkEither $ liftIO $ runClientM (update_node token nodeId params) clientEnv
-  ji' <- pollUntilWorkFinished port ji
+  ji' <- pollUntilWorkFinished log_cfg port ji
   liftIO $ ji' `shouldBe` ji
 
 mkNewWithForm :: T.Text -> T.Text -> NewWithForm

test/Test/Database/Setup.hs

@@ -2,7 +2,7 @@
 
 module Test.Database.Setup (
     withTestDB
-  , fakeTomlPath
+  , testTomlPath
   , testEnvToPgConnectionInfo
   ) where
 
@@ -28,7 +28,7 @@ import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
 import Gargantext.Core.Worker (initWorkerState)
 import Gargantext.Core.Worker.Env (WorkerEnv(..))
 import Gargantext.Prelude
-import Gargantext.System.Logging (withLoggerHoisted)
+import Gargantext.System.Logging (withLoggerIO)
 import Paths_gargantext
 import Prelude qualified
 import Shelly hiding (FilePath, run)
@@ -43,8 +43,8 @@ dbUser = "gargantua"
 dbPassword = "gargantua_test"
 dbName = "gargandb_test"
 
-fakeTomlPath :: IO SettingsFile
-fakeTomlPath = SettingsFile <$> getDataFileName "test-data/test_config.toml"
+testTomlPath :: IO SettingsFile
+testTomlPath = SettingsFile <$> getDataFileName "test-data/test_config.toml"
 
 gargDBSchema :: IO FilePath
 gargDBSchema = getDataFileName "devops/postgres/schema.sql"
@@ -81,7 +81,7 @@ setup = do
     Left err -> Prelude.fail $ show err
     Right db -> do
       let connInfo = tmpDBToConnInfo db
-      gargConfig <- fakeTomlPath >>= readConfig
+      gargConfig <- testTomlPath >>= readConfig
                     -- fix db since we're using tmp-postgres
                     <&> (gc_database_config .~ connInfo)
                     -- <&> (gc_worker . wsDatabase .~ connInfo)
@@ -98,8 +98,8 @@ setup = do
       bootstrapDB db pool gargConfig
       ugen <- emptyCounter
       test_nodeStory <- fromDBNodeStoryEnv pool
-      withLoggerHoisted Mock $ \logger -> do
-  
+      withLoggerIO Mock $ \logger -> do
+
         let wPoolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db))
                                             PG.close
                                             idleTime
@@ -107,7 +107,7 @@ setup = do
         wPool <- newPool (setNumStripes (Just 2) wPoolConfig)
         wNodeStory <- fromDBNodeStoryEnv wPool
         _w_env_job_state <- newTVarIO Nothing
-        withLoggerHoisted Mock $ \wioLogger -> do
+        withLoggerIO Mock $ \wioLogger -> do
           let wEnv = WorkerEnv { _w_env_config = gargConfig
                                , _w_env_logger = wioLogger
                                , _w_env_pool = wPool

test/Test/Database/Types.hs

@@ -144,7 +144,10 @@ instance HasLogger (GargM TestEnv BackendInternalError) where
     pure $ GargTestLogger mode test_logger_set
   destroyLogger GargTestLogger{..} = liftIO $ FL.rmLoggerSet test_logger_set
   logMsg (GargTestLogger mode logger_set) lvl msg = do
-    let pfx = "[" <> show lvl <> "] " :: Text
-    when (lvl `elem` (modeToLoggingLevels mode)) $
-      liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
+    cfg <- view hasConfig
+    let minLvl = cfg ^. gc_logging . lc_log_level
+    when (lvl >= minLvl) $ do
+      let pfx = "[" <> show lvl <> "] " :: Text
+      when (lvl `elem` (modeToLoggingLevels mode)) $
+        liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
   logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)

test/Test/Utils.hs

@@ -35,19 +35,20 @@ import Control.Concurrent.STM.TSem (TSem, waitTSem)
 import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVarIO)
 import Control.Exception.Safe ()
 import Control.Monad ()
-import Data.Aeson qualified as JSON
 import Data.Aeson.KeyMap qualified as KM
+import Data.Aeson qualified as JSON
 import Data.ByteString.Char8 qualified as B
 import Data.ByteString.Lazy qualified as L
 import Data.Map.Strict qualified as Map
-import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
-import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Encoding qualified as TLE
+import Data.Text.Lazy qualified as TL
+import Data.Text qualified as T
 import Data.TreeDiff
 import Gargantext.API.Admin.Auth.Types (AuthRequest(..), AuthResponse, Token, authRes_token)
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Routes.Types (xGargErrorScheme)
+import Gargantext.Core.Config (LogConfig)
 import Gargantext.Core.Notifications.Dispatcher.Types qualified as DT
 import Gargantext.Core.Types.Individu (Username, GargPassword)
 import Gargantext.Core.Worker.Types (JobInfo(..))
@@ -55,21 +56,21 @@ import Gargantext.Prelude
 import Gargantext.System.Logging (withLogger, logMsg, LogLevel(..))
 import Network.HTTP.Client (defaultManagerSettings, newManager)
 import Network.HTTP.Client qualified as HTTP
-import Network.HTTP.Types (Header, Method, status200)
 import Network.HTTP.Types.Header (hAccept, hAuthorization, hContentType)
+import Network.HTTP.Types (Header, Method, status200)
 import Network.Wai.Handler.Warp (Port)
 import Network.Wai.Test (SResponse(..))
 import Network.WebSockets qualified as WS
 import Prelude qualified
-import Servant.Client.Streaming (ClientEnv, baseUrlPort, mkClientEnv, parseBaseUrl, runClientM, makeClientRequest, defaultMakeClientRequest)
 import Servant.Client.Core (BaseUrl)
 import Servant.Client.Core.Request qualified as Client
+import Servant.Client.Streaming (ClientEnv, baseUrlPort, mkClientEnv, parseBaseUrl, runClientM, makeClientRequest, defaultMakeClientRequest)
 import System.Environment (lookupEnv)
 import System.Timeout qualified as Timeout
 import Test.API.Routes (auth_api)
 import Test.Hspec.Expectations
-import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request)
 import Test.Hspec.Wai.JSON (FromValue(..))
+import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request)
 import Test.Hspec.Wai.Matcher (MatchHeader(..), ResponseMatcher(..), bodyEquals, formatHeader, match)
 import Test.Tasty.HUnit (Assertion, assertBool)
 import Test.Utils.Notifications (withWSConnection, millisecond)
@@ -252,10 +253,11 @@ gargMkRequest traceEnabled bu clientRq = do
 
 
 pollUntilWorkFinished :: HasCallStack
-                      => Port
+                      => LogConfig
+                      -> Port
                       -> JobInfo
                       -> WaiSession () JobInfo
-pollUntilWorkFinished port ji = do
+pollUntilWorkFinished log_cfg port ji = do
   let waitSecs = 60
   isFinishedTVar <- liftIO $ newTVarIO False
   let wsConnect =
@@ -271,24 +273,24 @@ pollUntilWorkFinished port ji = do
             case dec of
               Nothing -> pure ()
               Just (DT.NUpdateWorkerProgress ji' jl) -> do
-                withLogger () $ \ioL ->
+                withLogger log_cfg $ \ioL ->
                   logMsg ioL DEBUG $ "[pollUntilWorkFinished] received " <> show ji' <> ", " <> show jl
                 if ji' == ji && isFinished jl
                 then do
-                  withLogger () $ \ioL ->
+                  withLogger log_cfg $ \ioL ->
                     logMsg ioL DEBUG $ "[pollUntilWorkFinished] FINISHED! " <> show ji'
                   atomically $ writeTVar isFinishedTVar True
                 else
                   pure ()
               _ -> pure ()
- 
+
   liftIO $ withAsync wsConnect $ \_ -> do
     mRet <- Timeout.timeout (waitSecs * 1000 * millisecond) $ do
       let go = do
             finished <- readTVarIO isFinishedTVar
             if finished
               then do
-                withLogger () $ \ioL ->
+                withLogger log_cfg $ \ioL ->
                   logMsg ioL DEBUG $ "[pollUntilWorkFinished] JOB FINISHED: " <> show ji
                 return True
               else do
@@ -298,7 +300,7 @@ pollUntilWorkFinished port ji = do
     case mRet of
       Nothing -> panicTrace $ "[pollUntilWorkFinished] timed out while waiting to finish job " <> show ji
       Just _ -> return ji
-      
+
 
   where
     isFinished (JobLog { .. }) = _scst_remaining == Just 0
@@ -317,7 +319,7 @@ waitUntil pred' timeoutMs = do
   -- shortcut for testing mTimeout
   p <- pred'
   unless p (expectationFailure "Predicate test failed")
-  
+
   where
     performTest = do
       p <- pred'