Plumb logging interface inside addToCorpusWithQuery

bin/gargantext-server/Main.hs

@@ -57,13 +57,14 @@ deriving instance Show (MyOptions Unwrapped)
 -- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
 instance HasLogger IO where
   data instance Logger IO        = IOLogger
-  type instance InitParams IO = ()
-  type instance Payload IO  = String
+  type instance LogInitParams IO = ()
+  type instance LogPayload IO    = String
   initLogger                     = \() -> pure IOLogger
   destroyLogger                  = \_  -> pure ()
   logMsg = \IOLogger lvl msg ->
     let pfx = "[" <> show lvl <> "] "
     in putStrLn $ pfx <> msg
+  logTxt lgr lvl msg = logMsg lgr lvl (unpack msg)
 
 main :: IO ()
 main = withLogger () $ \ioLogger -> do

src/Gargantext/API/Admin/EnvTypes.hs

@@ -34,6 +34,7 @@ import qualified Servant.Job.Async as SJ
 import qualified Servant.Job.Core
 
 import Data.List ((\\))
+import qualified Data.Text as T
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Admin.Types
 import Gargantext.API.Job
@@ -57,21 +58,24 @@ data Mode = Dev | Mock | Prod
 -- | Given the 'Mode' the server is running in, it returns the list of
 -- allowed levels. For example for production we ignore everything which
 -- has priority lower than "warning".
-modeToLoggingLevels :: Mode -> [Level]
+modeToLoggingLevels :: Mode -> [LogLevel]
 modeToLoggingLevels = \case
    Dev  -> [minBound .. maxBound]
    Mock -> [minBound .. maxBound]
    -- For production, accepts everything but DEBUG.
    Prod -> [minBound .. maxBound] \\ [DEBUG]
 
+instance MonadLogger (GargM Env GargError) where
+  getLogger = asks _env_logger
+
 instance HasLogger (GargM Env GargError) where
   data instance Logger (GargM Env GargError)  =
     GargLogger {
         logger_mode    :: Mode
       , logger_set     :: FL.LoggerSet
       }
-  type instance InitParams (GargM Env GargError) = Mode
-  type instance Payload (GargM Env GargError) = FL.LogStr
+  type instance LogInitParams (GargM Env GargError) = Mode
+  type instance LogPayload (GargM Env GargError)    = FL.LogStr
   initLogger                = \mode -> do
     logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
     pure $ GargLogger mode logger_set
@@ -80,6 +84,7 @@ instance HasLogger (GargM Env GargError) where
     let pfx = "[" <> show lvl <> "] "
     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)
 
 
 data GargJob

src/Gargantext/API/Node/Corpus/New.hs

@@ -67,6 +67,7 @@ import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
 import qualified Gargantext.Core.Text.Corpus.API as API
 import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileType(..), parseFormatC)
 import qualified Gargantext.Database.GargDB as GargDB
+import Gargantext.System.Logging
 
 ------------------------------------------------------------------------
 {-
@@ -201,16 +202,17 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
                                          , _wq_datafield = datafield
                                          , _wq_lang = l
                                          , _wq_flowListWith = flw }) maybeLimit jobHandle = do
+
   -- TODO ...
-  -- printDebug "[addToCorpusWithQuery] (cid, dbs)" (cid, dbs)
-  -- printDebug "[addToCorpusWithQuery] datafield" datafield
-  -- printDebug "[addToCorpusWithQuery] flowListWith" flw
+  logM DEBUG $ T.pack $ "[addToCorpusWithQuery] (cid, dbs) " <> show (cid, dbs)
+  logM DEBUG $ T.pack $ "[addToCorpusWithQuery] datafield  " <> show datafield
+  logM DEBUG $ T.pack $ "[addToCorpusWithQuery] flowListWith " <> show flw
 
   addLanguageToCorpus cid l
 
   case datafield of
     Just Web -> do
-      -- printDebug "[addToCorpusWithQuery] processing web request" datafield
+      logM DEBUG $ T.pack $ "[addToCorpusWithQuery] processing web request " <> show datafield
 
       markStarted 1 jobHandle
 
@@ -225,7 +227,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
       -- TODO if cid is folder -> create Corpus
       --      if cid is corpus -> add to corpus
       --      if cid is root   -> create corpus in Private
-      -- printDebug "[G.A.N.C.New] getDataText with query" q
+      logM DEBUG $ T.pack $ "[G.A.N.C.New] getDataText with query: " <> show q
       let db = database2origin dbs
       mPubmedAPIKey <- getUserPubmedAPIKey user
       -- printDebug "[addToCorpusWithQuery] mPubmedAPIKey" mPubmedAPIKey

src/Gargantext/API/Prelude.hs

@@ -89,7 +89,7 @@ type GargServerC env err m =
 
 type GargServerT env err m api = GargServerC env err m => ServerT api m
 
-type GargServer api = forall env err m. HasLogger m => GargServerT env err m api
+type GargServer api = forall env err m. MonadLogger m => GargServerT env err m api
 
 -- This is the concrete monad. It needs to be used as little as possible.
 type GargM env err = ReaderT env (ExceptT err IO)

src/Gargantext/Database/Action/Flow/Types.hs

@@ -38,7 +38,7 @@ type FlowCmdM env err m =
   , HasNodeError err
   , HasInvalidError err
   , HasTreeError err
-  , HasLogger m
+  , MonadLogger m
   )
 
 type FlowCorpus a = ( AddUniqId      a

src/Gargantext/System/Logging.hs

 {-# LANGUAGE TypeFamilies #-}
 
-module Gargantext.System.Logging where
+module Gargantext.System.Logging (
+    LogLevel(..)
+  , HasLogger(..)
+  , MonadLogger(..)
+  , logM
+  , withLogger
+  , withLoggerHoisted
+  ) where
 
-import Prelude
-import Data.Kind (Type)
-import Control.Monad.Trans.Control
 import Control.Exception.Lifted (bracket)
 import Control.Monad.IO.Class
+import Control.Monad.Trans.Control
+import Data.Kind (Type)
+import Prelude
+import qualified Data.Text as T
 
-data Level =
+data LogLevel =
   -- | Debug messages
   DEBUG
   -- | Information
@@ -33,22 +41,38 @@ data Level =
 -- the rest of the codebase.
 class HasLogger m where
   data family Logger m        :: Type
-  type family InitParams m :: Type
-  type family Payload m    :: Type
-  initLogger    :: InitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
+  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     -> Level -> Payload m -> m ()
+  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
+  logger <- getLogger
+  logTxt logger level msg
 
 -- | exception-safe combinator that creates and destroys a logger.
 -- Think about it like a 'bracket' function from 'Control.Exception'.
 withLogger :: (MonadBaseControl IO m, MonadIO m, HasLogger m)
-           => InitParams m
+           => LogInitParams m
            -> (Logger m -> m a)
            -> m a
 withLogger params = bracket (initLogger params) destroyLogger
 
+-- | Like 'withLogger', but it allows creating a 'Logger' that can run in
+-- a different monad from within an 'IO' action.
 withLoggerHoisted :: (MonadBaseControl IO m, HasLogger m)
-                  => InitParams m
+                  => LogInitParams m
                   -> (Logger m -> IO a)
                   -> IO a
 withLoggerHoisted params act = bracket (initLogger params) destroyLogger act