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

gargantext.cabal

@@ -54,6 +54,8 @@ data-files:
     test-data/stemming/lancaster.txt
     test-data/test_config.ini
     test-data/test_config.toml
+    test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir.tsv
+    test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir12.csv
     .clippy.dhall
 
 -- common options
@@ -309,6 +311,7 @@ library
       Gargantext.Orphans.Accelerate
       Gargantext.Orphans.OpenAPI
       Gargantext.System.Logging
+      Gargantext.System.Logging.Loggers
       Gargantext.System.Logging.Types
       Gargantext.Utils.Dict
       Gargantext.Utils.Jobs.Error
@@ -803,6 +806,7 @@ test-suite garg-test-tasty
   other-modules:
       CLI.Phylo.Common
       Paths_gargantext
+      Test.API.Private.List
       Test.API.Private.Move
       Test.API.Private.Remote
       Test.API.Private.Share
@@ -877,6 +881,7 @@ test-suite garg-test-hspec
       Test.API.GraphQL
       Test.API.Notifications
       Test.API.Private
+      Test.API.Private.List
       Test.API.Private.Move
       Test.API.Private.Remote
       Test.API.Private.Share

hie.yaml

@@ -68,9 +68,3 @@ cradle:
 
     - path: "./test"
       component: "gargantext:test:garg-test-hspec"
-
-    - path: "./bench/Main.hs"
-      component: "gargantext:bench:garg-bench"
-
-    - path: "./bench/Paths_gargantext.hs"
-      component: "gargantext:bench:garg-bench"

src/Gargantext/API.hs

@@ -70,8 +70,9 @@ 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) = withLoggerIO mode $ \logger -> do
+startGargantext mode port sf@(SettingsFile settingsFile) = do
   config <- readConfig sf <&> (gc_frontend_config . fc_appPort) .~ port
+  withLoggerIO (config ^. gc_logging) $ \logger -> do
     when (port /= config ^. gc_frontend_config . fc_appPort) $
       panicTrace "TODO: conflicting settings of port"
     withNotifications config $ \dispatcher -> do

src/Gargantext/API/Admin/EnvTypes.hs

@@ -38,12 +38,11 @@ module Gargantext.API.Admin.EnvTypes (
 import Control.Lens (to, view)
 import Data.List ((\\))
 import Data.Pool (Pool)
-import Data.Text qualified as T
 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(..), gc_logging, lc_log_level)
+import Gargantext.Core.Config
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap)
 import Gargantext.Core.NodeStory
@@ -58,6 +57,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Network.HTTP.Client (Manager)
 import Servant.Auth.Server (JWTSettings)
 import System.Log.FastLogger qualified as FL
+import Gargantext.System.Logging.Loggers
 
 
 data Mode = Dev | Mock | Prod
@@ -139,21 +139,13 @@ instance MonadLogger (GargM DevEnv BackendInternalError) where
 
 instance HasLogger (GargM DevEnv BackendInternalError) where
   data instance Logger (GargM DevEnv BackendInternalError)  =
-    GargDevLogger {
-        dev_logger_mode    :: Mode
-      , dev_logger_set     :: FL.LoggerSet
-      }
-  type instance LogInitParams (GargM DevEnv BackendInternalError) = Mode
+    GargDevLogger { _GargDevLogger :: MonadicStdLogger FL.LogStr IO }
+  type instance LogInitParams (GargM DevEnv BackendInternalError) = LogConfig
   type instance LogPayload (GargM DevEnv BackendInternalError)    = FL.LogStr
-  initLogger                = \mode -> do
-    dev_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
-    pure $ GargDevLogger mode dev_logger_set
-  destroyLogger             = \GargDevLogger{..}  -> liftIO $ FL.rmLoggerSet dev_logger_set
-  logMsg = \(GargDevLogger 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)
+  initLogger cfg = fmap GargDevLogger $ (liftIO $ monadicStdLogger cfg)
+  destroyLogger = liftIO . _msl_destroy . _GargDevLogger
+  logMsg (GargDevLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
+  logTxt (GargDevLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
 
 data DevEnv = DevEnv
   { _dev_env_config    :: !GargConfig
@@ -225,25 +217,14 @@ instance HasNLPServer DevEnv where
 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
+  newtype instance Logger (GargM Env BackendInternalError)  =
+    GargLogger { _GargLogger :: MonadicStdLogger FL.LogStr IO }
+  type instance LogInitParams (GargM Env BackendInternalError) = LogConfig
   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)
+  initLogger cfg = fmap GargLogger $ (liftIO $ monadicStdLogger cfg)
+  destroyLogger = liftIO . _msl_destroy . _GargLogger
+  logMsg (GargLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
+  logTxt (GargLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
 
 instance MonadLogger (GargM Env BackendInternalError) where
   getLogger = asks _env_logger

src/Gargantext/API/Dev.hs

@@ -16,11 +16,11 @@ import Control.Lens (view)
 import Control.Monad (fail)
 import Database.PostgreSQL.Simple qualified as PGS
 import Data.Pool (withResource)
-import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) )
+import Gargantext.API.Admin.EnvTypes ( DevEnv(..) )
 import Gargantext.API.Admin.Settings ( newPool )
 import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Prelude ( GargM )
-import Gargantext.Core.Config (_gc_database_config)
+import Gargantext.Core.Config (_gc_database_config, gc_logging)
 import Gargantext.Core.Config.Types (SettingsFile(..))
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
@@ -32,14 +32,14 @@ import Servant ( ServerError )
 
 -------------------------------------------------------------------
 withDevEnv :: SettingsFile -> (DevEnv -> IO a) -> IO a
-withDevEnv settingsFile k = withLoggerIO Dev $ \logger -> do
-  env <- newDevEnv logger
+withDevEnv settingsFile k = do
+  cfg <- readConfig settingsFile
+  withLoggerIO (cfg ^. gc_logging) $ \logger -> do
+    env <- newDevEnv logger cfg
     k env -- `finally` cleanEnv env
 
   where
-    newDevEnv logger = do
-      cfg     <- readConfig         settingsFile
-      --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
+    newDevEnv logger cfg = do
       pool    <- newPool (_gc_database_config cfg)
       nodeStory_env <- fromDBNodeStoryEnv pool
       manager <- newTlsManager

src/Gargantext/API/Ngrams/List.hs

@@ -21,21 +21,21 @@ import Data.ByteString.Lazy qualified as BSL
 import Data.Csv qualified as Tsv
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
-import Data.Map.Strict qualified as Map
 import Data.Map.Strict (toList)
+import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
 import Data.Text (concat, pack, splitOn)
-import Data.Vector qualified as Vec
 import Data.Vector (Vector)
+import Data.Vector qualified as Vec
 import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types (BackendInternalError(InternalServerError))
-import Gargantext.API.Ngrams.List.Types (_wjf_data, _wtf_data)
-import Gargantext.API.Ngrams.Prelude (getNgramsList)
 import Gargantext.API.Ngrams (setListNgrams)
+import Gargantext.API.Ngrams.List.Types (_wjf_data, _wtf_data, _wtf_name)
+import Gargantext.API.Ngrams.Prelude (getNgramsList)
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Prelude (GargM, serverError, HasServerError)
 import Gargantext.API.Routes.Named.List qualified as Named
-import Gargantext.API.Worker (serveWorkerAPI, serveWorkerAPIEJob)
+import Gargantext.API.Worker (serveWorkerAPI, serveWorkerAPIM)
 import Gargantext.Core.NodeStory.Types ( HasNodeStory )
 import Gargantext.Core.Text.Ngrams (Ngrams, NgramsType(NgramsTerms))
 import Gargantext.Core.Types.Main (ListType(..))
@@ -47,13 +47,12 @@ import Gargantext.Database.Schema.Ngrams ( text2ngrams, NgramsId )
 import Gargantext.Database.Schema.Node (_node_parent_id)
 import Gargantext.Database.Types (Indexed(..))
 import Gargantext.Prelude hiding (concat, toList)
-import Gargantext.System.Logging (logLocM, MonadLogger)
+import Gargantext.System.Logging
 import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Prelude qualified
 import Protolude qualified as P
 import Servant
 import Servant.Server.Generic (AsServerT)
-import Gargantext.System.Logging (LogLevel(..))
 
 
 getAPI :: Named.GETAPI (AsServerT (GargM Env BackendInternalError))
@@ -159,10 +158,11 @@ tsvAPI = tsvPostAsync
 tsvPostAsync :: Named.TSVAPI (AsServerT (GargM Env BackendInternalError))
 tsvPostAsync =
   Named.TSVAPI {
-    updateListTSVEp = \lId -> serveWorkerAPIEJob $ \p ->
+    updateListTSVEp = \lId -> serveWorkerAPIM $ \p -> do
+      $(logLocM) DEBUG $ "Started to upload " <> (_wtf_name p)
       case ngramsListFromTSVData (_wtf_data p) of
-        Left err         -> Left $ InternalServerError $ err500 { errReasonPhrase = err }
-        Right ngramsList -> Right $ Jobs.JSONPost { _jp_list_id = lId
+        Left err         -> throwError $ InternalServerError $ err500 { errReasonPhrase = err }
+        Right ngramsList -> pure $ Jobs.JSONPost { _jp_list_id = lId
                                                  , _jp_ngrams_list = ngramsList }
     }
 
@@ -181,7 +181,8 @@ ngramsListFromTSVData tsvData = case decodeTsv of
     decodeTsv = Vec.catMaybes <$>
                    Tsv.decodeWithP tsvToNgramsTableMap
                                    (Tsv.defaultDecodeOptions { Tsv.decDelimiter = fromIntegral (P.ord '\t') })
-                                   Tsv.HasHeader
+                                   -- Don't use an header, make it lenient in case the 'forms' are missing.
+                                   Tsv.NoHeader
                                    binaryData
 
 -- | Converts a plain TSV 'Record' into an NgramsTableMap
@@ -189,6 +190,9 @@ tsvToNgramsTableMap :: Tsv.Record -> Tsv.Parser (Maybe NgramsTableMap)
 tsvToNgramsTableMap record = case Vec.toList record of
   (map P.decodeUtf8 -> [status, label, forms])
     -> pure $ Just $ conv status label forms
+  -- Garg #381: alias the forms to the empty text.
+  (map P.decodeUtf8 -> [status, label])
+    -> pure $ Just $ conv status label mempty
   -- WARNING: This silently ignores errors (#433)
   _ -> pure Nothing
 

src/Gargantext/API/Worker.hs

@@ -32,10 +32,15 @@ data WorkerAPI contentType input mode = WorkerAPI
 serveWorkerAPI :: IsGargServer env err m
                => (input -> Job)
                -> WorkerAPI contentType input (AsServerT m)
-serveWorkerAPI f = WorkerAPI { workerAPIPost }
+serveWorkerAPI f = serveWorkerAPIM (pure . f)
+
+serveWorkerAPIM :: IsGargServer env err m
+                => (input -> m Job)
+                -> WorkerAPI contentType input (AsServerT m)
+serveWorkerAPIM mkJob = WorkerAPI { workerAPIPost }
   where
     workerAPIPost i = do
-      let job = f i
+      job <- mkJob i
       logM DEBUG $ "[serveWorkerAPI] sending job " <> show job
       mId <- sendJob job
       pure $ JobInfo { _ji_message_id = mId

src/Gargantext/Core/Config/Utils.hs

@@ -16,37 +16,27 @@ module Gargantext.Core.Config.Utils (
 
 import Gargantext.Core.Config.Types (SettingsFile(..))
 import Gargantext.Prelude
--- import Network.URI (URI)
--- import Network.URI (parseURI)
 import Toml
-import Toml.Schema
+import Gargantext.Core.Config
+import System.Environment (lookupEnv)
+import Gargantext.System.Logging.Types (parseLogLevel)
+import qualified Data.Text as T
 
 
-readConfig :: FromValue a => SettingsFile -> IO a
+readConfig :: SettingsFile -> IO GargConfig
 readConfig (SettingsFile fp) = do
   c <- readFile fp
 
   case decode c of
     Failure err -> panicTrace ("Error reading TOML file: " <> show err)
-    Success _ r -> return r
-
-
--- _URI :: Toml.TomlBiMap URI Text
--- _URI = Toml.BiMap (Right . show) parseURI'
---   where
---     parseURI' :: Text -> Either Toml.TomlBiMapError URI
---     parseURI' t =
---       case parseURI (T.unpack t) of
---         Nothing -> Left $ Toml.ArbitraryError "Cannot parse URI"
---         Just u -> Right u
-
--- uriToml :: Toml.Key -> Toml.TomlCodec URI
--- uriToml = Toml.match (_URI >>> Toml._Text)
-
-
--- _Word16 :: Toml.TomlBiMap Word16 Toml.AnyValue
--- _Word16 = Toml._BoundedInteger >>> Toml._Integer
-
-
--- word16Toml :: Toml.Key -> Toml.TomlCodec Word16
--- word16Toml = Toml.match _Word16
+    Success _ r -> do
+      -- Ovverride the log level based on the GGTX_LOG_LEVEL (if set)
+      mLvl <- lookupEnv "GGTX_LOG_LEVEL"
+      case mLvl of
+        Nothing      -> pure r
+        Just s       ->
+          case parseLogLevel (T.pack s) of
+            Left err   -> do
+              putStrLn $ "unknown log level " <> s <> ": " <> T.unpack err <> " , ignoring GGTX_LOG_LEVEL"
+              pure r
+            Right lvl' -> pure $ r & gc_logging . lc_log_level .~ lvl'

src/Gargantext/Core/Text/List/Formats/TSV.hs

@@ -54,7 +54,9 @@ data TsvList = TsvList
 instance FromNamedRecord TsvList where
   parseNamedRecord r = TsvList <$> r .: "status"
                                <*> r .: "label"
-                               <*> r .: "forms"
+                               -- Issue #381: be lenient in the forms
+                               -- field, if missing, default to the empty text.
+                               <*> (fromMaybe mempty <$> r .: "forms")
 
 instance ToNamedRecord TsvList where
   toNamedRecord (TsvList s l f) =

src/Gargantext/Core/Worker/Env.hs

@@ -24,15 +24,13 @@ import Control.Lens.TH
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Maybe (fromJust)
 import Data.Pool qualified as Pool
-import Data.Text qualified as T
 import Database.PostgreSQL.Simple qualified as PSQL
-import Gargantext.API.Admin.EnvTypes (Mode(Dev), modeToLoggingLevels)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
 import Gargantext.API.Job (RemainingSteps(..), jobLogStart, jobLogProgress, jobLogFailures, jobLogComplete, addErrorEvent, jobLogFailTotal, jobLogFailTotalWithMessage, jobLogAddMore)
 import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Notifications.CentralExchange qualified as CE
 import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
-import Gargantext.Core.Config (GargConfig(..), HasConfig(..), gc_logging)
+import Gargantext.Core.Config (GargConfig(..), HasConfig(..), gc_logging, LogConfig)
 import Gargantext.Core.Config.Mail qualified as Mail
 import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.Config.Types (SettingsFile(..))
@@ -50,6 +48,7 @@ import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
 import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))
 import Prelude qualified
 import System.Log.FastLogger qualified as FL
+import Gargantext.System.Logging.Loggers
 
 
 data WorkerEnv = WorkerEnv
@@ -70,13 +69,14 @@ data WorkerJobState = WorkerJobState
 
 
 withWorkerEnv :: SettingsFile -> (WorkerEnv -> IO a) -> IO a
-withWorkerEnv settingsFile k = withLoggerIO Dev $ \logger -> do
-  env <- newWorkerEnv logger
+withWorkerEnv settingsFile k = do
+  cfg <- readConfig settingsFile
+  withLoggerIO (cfg ^. gc_logging) $ \logger -> do
+    env <- newWorkerEnv logger cfg
     k env -- `finally` cleanEnv env
 
   where
-    newWorkerEnv logger = do
-      cfg     <- readConfig         settingsFile
+    newWorkerEnv logger cfg = do
       --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
       -- pool    <- newPool            $ _gc_database_config cfg
       let dbConfig = _gc_database_config cfg
@@ -97,22 +97,14 @@ instance HasConfig WorkerEnv where
   hasConfig = to _w_env_config
 
 instance HasLogger (GargM WorkerEnv IOException) where
-  data instance Logger (GargM WorkerEnv IOException)  =
-    GargWorkerLogger {
-        w_logger_mode    :: Mode
-      , w_logger_set     :: FL.LoggerSet
-      }
-  type instance LogInitParams (GargM WorkerEnv IOException) = Mode
+  newtype instance Logger (GargM WorkerEnv IOException)  =
+    GargWorkerLogger { _GargWorkerLogger :: MonadicStdLogger FL.LogStr IO }
+  type instance LogInitParams (GargM WorkerEnv IOException) = LogConfig
   type instance LogPayload (GargM WorkerEnv IOException)    = FL.LogStr
-  initLogger mode = do
-    w_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
-    pure $ GargWorkerLogger mode w_logger_set
-  destroyLogger (GargWorkerLogger{..}) = liftIO $ FL.rmLoggerSet w_logger_set
-  logMsg (GargWorkerLogger 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)
+  initLogger cfg = fmap GargWorkerLogger $ (liftIO $ monadicStdLogger cfg)
+  destroyLogger = liftIO . _msl_destroy . _GargWorkerLogger
+  logMsg (GargWorkerLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
+  logTxt (GargWorkerLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
 
 instance HasConnectionPool WorkerEnv where
   connPool = to _w_env_pool
@@ -182,29 +174,20 @@ newtype WorkerMonad a =
            , MonadFail )
 
 instance HasLogger WorkerMonad where
-  data instance Logger WorkerMonad =
-    WorkerMonadLogger {
-        wm_logger_mode    :: Mode
-      , wm_logger_set     :: FL.LoggerSet
-      }
-  type instance LogInitParams WorkerMonad = Mode
+  newtype instance Logger WorkerMonad =
+    WorkerMonadLogger { _WorkerMonadLogger :: MonadicStdLogger FL.LogStr IO }
+  type instance LogInitParams WorkerMonad = LogConfig
   type instance LogPayload WorkerMonad    = FL.LogStr
-  initLogger mode = do
-    wm_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
-    pure $ WorkerMonadLogger mode wm_logger_set
-  destroyLogger (WorkerMonadLogger{..}) = liftIO $ FL.rmLoggerSet wm_logger_set
-  logMsg (WorkerMonadLogger 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)
+  initLogger cfg = fmap WorkerMonadLogger $ (liftIO $ monadicStdLogger cfg)
+  destroyLogger = liftIO . _msl_destroy . _WorkerMonadLogger
+  logMsg (WorkerMonadLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
+  logTxt (WorkerMonadLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg
 
 instance MonadLogger WorkerMonad where
   getLogger = do
     env <- ask
-    let (GargWorkerLogger { .. }) = _w_env_logger env
-    pure $ WorkerMonadLogger { wm_logger_mode = w_logger_mode
-                             , wm_logger_set = w_logger_set }
+    let (GargWorkerLogger lgr) = _w_env_logger env
+    pure $ WorkerMonadLogger lgr
 
 runWorkerMonad :: WorkerEnv -> WorkerMonad a -> IO a
 runWorkerMonad env m = do

src/Gargantext/System/Logging.hs

@@ -13,17 +13,15 @@ module Gargantext.System.Logging (
   ) where
 
 import Gargantext.System.Logging.Types
+import Gargantext.System.Logging.Loggers
 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.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)
 
 
 -- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
@@ -86,25 +84,10 @@ 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
+  data instance Logger IO        = IOLogger { _IOLogger :: IOStdLogger }
   type instance LogInitParams IO = LogConfig
   type instance LogPayload IO    = String
-  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 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
-    t <- getCurrentTime
-    when (lvl >= minLvl) $ do
-      let pfx = "[" <> show t <> "] [" <> show lvl <> "] "
-      putStrLn $ pfx <> msg
-  logTxt lgr lvl msg = logMsg lgr lvl (T.unpack msg)
+  initLogger cfg = fmap IOLogger $ (liftIO $ ioStdLogger cfg)
+  destroyLogger = liftIO . _iosl_destroy . _IOLogger
+  logMsg (IOLogger ioLogger) = _iosl_log_msg ioLogger
+  logTxt (IOLogger ioLogger) lvl msg = liftIO $ _iosl_log_txt ioLogger lvl msg

src/Gargantext/System/Logging/Loggers.hs

+
+{-| Canned loggers to avoid reinventing the wheel every time. -}
+
+module Gargantext.System.Logging.Loggers (
+    ioStdLogger
+  , IOStdLogger -- opaque, you can't build it directly, use 'ioStdLogger'
+  , _iosl_log_level
+  , _iosl_destroy
+  , _iosl_log_msg
+  , _iosl_log_txt
+  , monadicStdLogger
+  , _msl_log_level
+  , _msl_destroy
+  , _msl_log_msg
+  , _msl_log_txt
+  , MonadicStdLogger
+  ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Text qualified as T
+import Data.Time
+import Gargantext.Core.Config
+import Gargantext.System.Logging.Types
+import Prelude
+import System.Log.FastLogger qualified as FL
+
+data IOStdLogger =
+  IOStdLogger { _iosl_log_level :: LogLevel
+              , _iosl_destroy   :: IO ()
+              , _iosl_log_msg   :: LogLevel -> String -> IO ()
+              , _iosl_log_txt   :: LogLevel -> T.Text -> IO ()
+              }
+
+ioStdLogger :: LogConfig -> IO IOStdLogger
+ioStdLogger LogConfig{..} = do
+  let minLvl = _lc_log_level
+  let log_msg lvl msg = do
+        t <- getCurrentTime
+        when (lvl >= minLvl) $ do
+          let pfx = "[" <> show t <> "] [" <> show lvl <> "] "
+          putStrLn $ pfx <> msg
+  pure $ IOStdLogger
+    { _iosl_log_level = minLvl
+    , _iosl_destroy   = pure ()
+    , _iosl_log_msg   = log_msg
+    , _iosl_log_txt = \lvl msg -> log_msg lvl (T.unpack msg)
+    }
+
+-- | A monadic standard logger powered by fast-logger underneath.
+data MonadicStdLogger payload m =
+  MonadicStdLogger { _msl_log_level :: LogLevel
+                   , _msl_loggers   :: [FL.LoggerSet]
+                   , _msl_destroy   :: m ()
+                   , _msl_log_msg   :: LogLevel -> payload -> m ()
+                   , _msl_log_txt   :: LogLevel -> T.Text -> m ()
+                   }
+
+monadicStdLogger :: MonadIO m => LogConfig -> IO (MonadicStdLogger FL.LogStr m)
+monadicStdLogger LogConfig{..} = do
+  let minLvl = _lc_log_level
+  stdout_logger <- FL.newStderrLoggerSet FL.defaultBufSize
+  let log_msg lvl msg = liftIO $ do
+        t <- getCurrentTime
+        when (lvl >= minLvl) $ do
+          let pfx = "[" <> show t <> "] [" <> show lvl <> "] "
+          FL.pushLogStrLn stdout_logger $ FL.toLogStr pfx <> msg
+  pure $ MonadicStdLogger
+    { _msl_log_level = minLvl
+    , _msl_loggers   = [stdout_logger]
+    , _msl_destroy   = liftIO $ FL.rmLoggerSet stdout_logger
+    , _msl_log_msg   = log_msg
+    , _msl_log_txt   = \lvl msg -> log_msg lvl (FL.toLogStr $ T.unpack msg)
+    }

test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir.tsv

+status	label
+map	impact-point analysis
+map	Simulated Destructive Re-Entry Conditions
+map	Passive Space-Debris Trajectories
+map	error-proofing mechanisms
+map	on-orbit life extension
+map	tether-gripper mechanism
+map	Field-Programmable Gate Arrays (FPGA)
+map	self-repair modular robot
+map	space-debris impact
+map	self-repairing
+map	in-orbit servicing
+map	online self-repairing
+map	triple-module redundancy systems
+map	model-based system engineering
+map	low-thrust orbital transfer
+map	space-borne orbit debris surveillance
+map	atmospheric re-entry
+map	demisable tanks' re-entry
+map	non-cooperative spacecraft
+map	model-based approaches
+map	model-based methods
+map	impact-induced electrical anomalies
+map	Low-Cost Deorbit System
+map	tape-shaped tethers
+map	self-repair
+map	self-healing material
+map	vision-based navigation
+map	model-based process

test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir12.csv

+status,label
+map,impact-point analysis
+map,Simulated Destructive Re-Entry Conditions
+map,Passive Space-Debris Trajectories
+map,error-proofing mechanisms
+map,on-orbit life extension
+map,tether-gripper mechanism
+map,Field-Programmable Gate Arrays (FPGA)
+map,self-repair modular robot
+map,space-debris impact
+map,self-repairing
+map,in-orbit servicing
+map,online self-repairing
+map,triple-module redundancy systems
+map,model-based system engineering
+map,low-thrust orbital transfer
+map,space-borne orbit debris surveillance
+map,atmospheric re-entry
+map,demisable tanks' re-entry
+map,non-cooperative spacecraft
+map,model-based approaches
+map,model-based methods
+map,impact-induced electrical anomalies
+map,Low-Cost Deorbit System
+map,tape-shaped tethers
+map,self-repair
+map,self-healing material
+map,vision-based navigation
+map,model-based process

test/Test/API/Private.hs

@@ -23,6 +23,7 @@ import Test.API.Private.Move  qualified as Move
 import Test.API.Private.Remote  qualified as Remote
 import Test.API.Private.Share qualified as Share
 import Test.API.Private.Table qualified as Table
+import Test.API.Private.List qualified as List
 import Test.API.Routes (mkUrl, get_node, get_tree)
 import Test.API.Setup (withTestDBAndPort, dbEnvSetup, SpecContext (..))
 import Test.Hspec
@@ -114,3 +115,5 @@ tests = sequential $ do
     Move.tests
   describe "Remote API" $ do
     Remote.tests
+  describe "List API" $ do
+    List.tests

test/Test/API/Private/List.hs

+{-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+
+module Test.API.Private.List (
+    tests
+  ) where
+
+import Data.Aeson.QQ
+import Data.Text.IO qualified as TIO
+import Gargantext.API.Ngrams.List.Types
+import Gargantext.API.Ngrams.Types qualified as APINgrams
+import Gargantext.API.Node.Corpus.New.Types qualified as FType
+import Gargantext.Core.Config
+import Gargantext.Core.Types
+import Gargantext.Core.Types.Individu
+import Gargantext.Prelude
+import Paths_gargantext
+import Servant.Client.Streaming
+import Test.API.Prelude (newCorpusForUser, checkEither)
+import Test.API.Routes
+import Test.API.Setup
+import Test.Database.Types
+import Test.Hspec (Spec, it, aroundAll, describe, sequential)
+import Test.Hspec.Expectations
+import Test.Hspec.Wai.Internal (withApplication)
+import Test.Utils
+import Fmt
+
+tests :: Spec
+tests = sequential $ aroundAll withTestDBAndPort $ do
+  describe "Prelude" $ do
+    it "setup DB triggers" $ \SpecContext{..} -> do
+      setupEnvironment _sctx_env
+      -- Let's create the Alice user.
+      void $ createAliceAndBob _sctx_env
+
+    describe "Importing terms as TSV" $ do
+
+      it "[#381] should work (and return a non-empty list of ngrams" $ \(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"}|]
+            -- Upload the CSV doc
+            simpleNgrams <- liftIO (TIO.readFile =<< getDataFileName "test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir.tsv")
+            let params = WithTextFile { _wtf_filetype = FType.TSV
+                                      , _wtf_data = simpleNgrams
+                                      , _wtf_name = "simple.tsv" }
+            ji <- checkEither $ liftIO $ runClientM (add_tsv_to_list token listId params) clientEnv
+            _ <- pollUntilWorkFinished log_cfg port ji
+
+            -- Now check that we can retrieve the ngrams, and the ngrams list is not empty!
+            liftIO $ do
+              eRes <- checkEither $ runClientM (get_table_ngrams token cId APINgrams.Terms listId 50 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
+              let (APINgrams.NgramsTable terms) = APINgrams._vc_data eRes
+              length terms `shouldSatisfy` (>= 1)

test/Test/API/Private/Remote.hs

@@ -7,11 +7,11 @@ module Test.API.Private.Remote (
   ) where
 
 import Control.Lens
-import Gargantext.API.Admin.EnvTypes (Mode(..))
 import Gargantext.API.Errors
 import Gargantext.API (makeApp)
 import Gargantext.API.Routes.Client (remoteExportClient)
 import Gargantext.API.Routes.Named.Remote (RemoteExportRequest(..))
+import Gargantext.Core.Config
 import Gargantext.Core.Types.Individu
 import Gargantext.Core.Types (NodeId(UnsafeMkNodeId))
 import Gargantext.Prelude
@@ -32,10 +32,10 @@ withTwoServerInstances :: (SpecContext (TestEnv,Wai.Application,Warp.Port) -> IO
 withTwoServerInstances action =
   withTestDB $ \testEnv1 -> do
     withTestDB $ \testEnv2 -> do
-      garg1App <- withLoggerIO Mock $ \ioLogger -> do
+      garg1App <- withLoggerIO (log_cfg testEnv1) $ \ioLogger -> do
                    env <- newTestEnv testEnv1 ioLogger server1Port
                    makeApp env
-      garg2App <- withLoggerIO Mock $ \ioLogger -> do
+      garg2App <- withLoggerIO (log_cfg testEnv2) $ \ioLogger -> do
                    env <- newTestEnv testEnv2 ioLogger server2Port
                    makeApp env
 
@@ -45,6 +45,7 @@ withTwoServerInstances action =
   where
     server1Port = 8008
     server2Port = 9008
+    log_cfg te  = (test_config te) ^. gc_logging
 
 tests :: Spec
 tests = sequential $ aroundAll withTwoServerInstances $ do

test/Test/API/Setup.hs

@@ -20,7 +20,7 @@ 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.Admin.EnvTypes (Mode(Mock), Env (..), env_dispatcher)
+import Gargantext.API.Admin.EnvTypes (Env (..), env_dispatcher)
 import Gargantext.API.Errors.Types
 import Gargantext.API (makeApp)
 import Gargantext.API.Prelude
@@ -112,7 +112,7 @@ nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560"
 withTestDBAndPort :: (SpecContext () -> IO ()) -> IO ()
 withTestDBAndPort action = withTestDB $ \testEnv -> do
   withNotifications (cfg testEnv) $ \dispatcher -> do
-    withLoggerIO Mock $ \ioLogger -> do
+    withLoggerIO (log_cfg testEnv) $ \ioLogger -> do
       env <- newTestEnv testEnv ioLogger 8080
              <&> env_dispatcher .~ dispatcher
       app <- makeApp env
@@ -147,11 +147,11 @@ withTestDBAndPort action = withTestDB $ \testEnv -> do
 withBackendServerAndProxy :: (((TestEnv, Warp.Port, Warp.Port)) -> IO ()) -> IO ()
 withBackendServerAndProxy action =
   withTestDB $ \testEnv -> do
-    gargApp <- withLoggerIO Mock $ \ioLogger -> do
+    gargApp <- withLoggerIO (log_cfg testEnv) $ \ioLogger -> do
                  env <- newTestEnv testEnv ioLogger 8080
                  makeApp env
     proxyCache <- InMemory.newCache Nothing
-    proxyApp <- withLoggerIO Mock $ \ioLogger -> do
+    proxyApp <- withLoggerIO (log_cfg testEnv) $ \ioLogger -> do
                   env <- newTestEnv testEnv ioLogger 8080
                   pure $ microServicesProxyApp proxyCache env
 
@@ -160,6 +160,8 @@ withBackendServerAndProxy action =
         action (testEnv, serverPort, proxyPort)
   where
     proxyPort = 8090
+    cfg te     = test_config te
+    log_cfg te = (cfg te) ^. gc_logging
 
 setupEnvironment :: TestEnv -> IO ()
 setupEnvironment env = flip runReaderT env $ runTestMonad $ do

test/Test/Database/Setup.hs

@@ -18,7 +18,6 @@ import Database.PostgreSQL.Simple qualified as PG
 import Database.PostgreSQL.Simple.Options qualified as Client
 import Database.PostgreSQL.Simple.Options qualified as Opts
 import Database.Postgres.Temp qualified as Tmp
-import Gargantext.API.Admin.EnvTypes (Mode(Mock))
 import Gargantext.Core.Config
 import Gargantext.Core.Config.Types (SettingsFile(..))
 import Gargantext.Core.Config.Utils (readConfig)
@@ -88,6 +87,7 @@ setup = do
                     <&> (gc_worker . wsDatabase .~ (connInfo { PG.connectDatabase = "pgmq_test" }))
       -- putText $ "[setup] database: " <> show (gargConfig ^. gc_database_config)
       -- putText $ "[setup] worker db: " <> show (gargConfig ^. gc_worker . wsDatabase)
+      let log_cfg = gargConfig ^. gc_logging
       let idleTime = 60.0
       let maxResources = 2
       let poolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db))
@@ -98,7 +98,7 @@ setup = do
       bootstrapDB db pool gargConfig
       ugen <- emptyCounter
       test_nodeStory <- fromDBNodeStoryEnv pool
-      withLoggerIO Mock $ \logger -> do
+      withLoggerIO log_cfg $ \logger -> do
 
         let wPoolConfig = defaultPoolConfig (PG.connectPostgreSQL (Tmp.toConnectionString db))
                                             PG.close
@@ -107,7 +107,7 @@ setup = do
         wPool <- newPool (setNumStripes (Just 2) wPoolConfig)
         wNodeStory <- fromDBNodeStoryEnv wPool
         _w_env_job_state <- newTVarIO Nothing
-        withLoggerIO Mock $ \wioLogger -> do
+        withLoggerIO log_cfg $ \wioLogger -> do
           let wEnv = WorkerEnv { _w_env_config = gargConfig
                                , _w_env_logger = wioLogger
                                , _w_env_pool = wPool

test/Test/Database/Types.hs

@@ -22,11 +22,9 @@ import Control.Monad.Trans.Control
 import Data.IORef
 import Data.Map qualified as Map
 import Data.Pool
-import Data.Text qualified as T
 import Database.PostgreSQL.Simple qualified as PG
 import Database.Postgres.Temp qualified as Tmp
 import Gargantext hiding (to)
-import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
@@ -36,6 +34,7 @@ import Gargantext.Core.Mail.Types (HasMail(..))
 import Gargantext.Core.NLP (HasNLPServer(..))
 import Gargantext.Core.NodeStory
 import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..))
+import Gargantext.System.Logging.Loggers
 import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Network.URI (parseURI)
 import Prelude qualified
@@ -132,22 +131,11 @@ instance MonadLogger (GargM TestEnv BackendInternalError) where
   getLogger = asks test_logger
 
 instance HasLogger (GargM TestEnv BackendInternalError) where
-  data instance Logger (GargM TestEnv BackendInternalError) =
-    GargTestLogger {
-      test_logger_mode :: Mode
-    , test_logger_set  :: FL.LoggerSet
-    }
-  type instance LogInitParams (GargM TestEnv BackendInternalError) = Mode
+  newtype instance Logger (GargM TestEnv BackendInternalError) =
+    GargTestLogger { _GargTestLogger :: MonadicStdLogger FL.LogStr IO }
+  type instance LogInitParams (GargM TestEnv BackendInternalError) = LogConfig
   type instance LogPayload (GargM TestEnv BackendInternalError)    = FL.LogStr
-  initLogger mode = do
-    test_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
-    pure $ GargTestLogger mode test_logger_set
-  destroyLogger GargTestLogger{..} = liftIO $ FL.rmLoggerSet test_logger_set
-  logMsg (GargTestLogger 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)
+  initLogger cfg = fmap GargTestLogger $ (liftIO $ monadicStdLogger cfg)
+  destroyLogger = liftIO . _msl_destroy . _GargTestLogger
+  logMsg (GargTestLogger ioLogger) lvl msg = liftIO $ _msl_log_msg ioLogger lvl msg
+  logTxt (GargTestLogger ioLogger) lvl msg = liftIO $ _msl_log_txt ioLogger lvl msg