refactoring(logger): Silence debug logs in tests

This commit correctly propagates the correct `LogConfig` in all the
places where we were just defaulting to log everything, and this allows
us to silence debug logs in tests, unless we want them.

gargantext.cabal

@@ -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

src/Gargantext/API.hs

@@ -74,8 +74,7 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerIO mode $ \
   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

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/Core/Config.hs

@@ -43,7 +43,7 @@ module Gargantext.Core.Config (
   ) where
 
 import Control.Lens (Getter)
-import Gargantext.System.Logging (LogLevel, parseLogLevel)
+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)

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

@@ -23,8 +23,9 @@ 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
@@ -45,14 +46,14 @@ 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
+      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
+      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
 
@@ -63,7 +64,7 @@ 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
@@ -71,8 +72,10 @@ gServer (NotificationsConfig { .. }) = do
             -- 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
@@ -104,14 +107,17 @@ gServer (NotificationsConfig { .. }) = do
               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 ->
+      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

@@ -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
 
 {-
 
@@ -55,11 +56,11 @@ 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
 
@@ -67,10 +68,10 @@ withDispatcher nc cb = do
 -- | 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
+    withLogger log_cfg $ \ioLogger -> do
       logMsg ioLogger DEBUG $ "[dispatcherListener] binding to " <> T.unpack _nc_dispatcher_bind
     _ <- bind s $ T.unpack _nc_dispatcher_bind
 
@@ -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,6 +90,8 @@ 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
 
@@ -98,10 +101,10 @@ dispatcherListener (NotificationsConfig { _nc_dispatcher_bind }) subscriptions =
 
         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 ->
+            withLogger log_cfg $ \ioL ->
               logMsg ioL DEBUG $ "[dispatcher_listener] received " <> show ceMessage
             -- subs <- atomically $ readTVar subscriptions
             filteredSubs <- atomically $ do
@@ -161,9 +164,9 @@ 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 ->
+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(..))
@@ -137,9 +139,9 @@ instance CET.HasCentralExchangeNotification WorkerEnv where
   ce_notify m = do
     c <- asks (view $ to _w_env_config)
     liftBase $ do
-      withLogger () $ \ioL ->
+      withLogger (c ^. gc_logging) $ \ioL ->
         logMsg ioL DEBUG $ "[ce_notify]: " <> show (_gc_notifications_config c) <> " :: " <> show m
-      CE.notify (_gc_notifications_config c) m
+      CE.notify c m
 
 ---------
 instance HasValidationError IOException where
@@ -265,3 +267,5 @@ updateJobProgress (WorkerJobHandle (ji@JobInfo { _ji_message_id })) f = do
       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 LambdaCase #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeApplications     #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Gargantext.System.Logging (
-    LogLevel(..)
-  , HasLogger(..)
-  , MonadLogger(..)
-  , parseLogLevel
-  , renderLogLevel
-  , prop_loglevel_roundtrip
+    module Gargantext.System.Logging.Types
   , logM
   , logLocM
   , logLoc
@@ -17,70 +12,20 @@ module Gargantext.System.Logging (
   , 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 =
-  -- | 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)
-
 -- | 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
@@ -142,16 +87,19 @@ withLoggerIO params act = bracket (initLogger params) destroyLogger act
 -- 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
+  initLogger LogConfig{..} = do
+    -- let the env var take precedence over the LogConfig one.
     mLvl <- liftIO $ lookupEnv "GGTX_LOG_LEVEL"
-    let lvl = case mLvl of
-          Nothing      -> INFO
+    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/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/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,8 +110,8 @@ 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
+withTestDBAndPort action = withTestDB $ \testEnv -> do
+  withNotifications (cfg testEnv) $ \dispatcher -> do
     withLoggerIO Mock $ \ioLogger -> do
       env <- newTestEnv testEnv ioLogger 8080
              <&> env_dispatcher .~ dispatcher
@@ -124,19 +126,21 @@ 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.

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
 
@@ -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)
@@ -99,7 +99,7 @@ setup = do
       ugen <- emptyCounter
       test_nodeStory <- fromDBNodeStoryEnv pool
       withLoggerIO Mock $ \logger -> do
-  
+
         let wPoolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db))
                                             PG.close
                                             idleTime

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'