Add logging capabilities to a DbTx monad

src/Gargantext/API/Ngrams/List.hs

@@ -146,11 +146,12 @@ postAsyncJSON l ngramsList jobHandle = do
 
   markProgress 1 jobHandle
 
-  corpus_node <- runDBQuery $ getNode l -- (Proxy :: Proxy HyperdataList)
-  let corpus_id = fromMaybe (panicTrace "no parent_id") (_node_parent_id corpus_node)
-  $(logLocM) DEBUG "[postAsyncJSON] Executing re-indexing..."
-  _ <- runDBTx $ reIndexWith env corpus_id l NgramsTerms (Set.fromList [MapTerm, CandidateTerm])
-  $(logLocM) DEBUG "[postAsyncJSON] Re-indexing done."
+  runDBTx $ do
+    corpus_node <- getNode l -- (Proxy :: Proxy HyperdataList)
+    let corpus_id = fromMaybe (panicTrace "no parent_id") (_node_parent_id corpus_node)
+    $(txLogLocM) DEBUG "[postAsyncJSON] Executing re-indexing..."
+    _ <- reIndexWith env corpus_id l NgramsTerms (Set.fromList [MapTerm, CandidateTerm])
+    $(txLogLocM) DEBUG "[postAsyncJSON] Re-indexing done."
 
   markComplete jobHandle
 

src/Gargantext/Database/Transactional.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 {--| This module exposes a custom monad and functions to model database operations within Gargantext.
  The peculiarity of the custom monad is that it describe a DSL for the operations we wish to perform,
@@ -33,6 +34,9 @@ module Gargantext.Database.Transactional (
   , mkOpaInsert
   , mkOpaDelete
 
+  -- * Emitting log messages
+  , txLogLocM
+
   -- * Throwing and catching errors (which allows rollbacks)
   , dbFail
   , catchDBTxError
@@ -49,12 +53,27 @@ import Control.Monad.Trans.Control (MonadBaseControl, control)
 import Data.Int (Int64)
 import Data.Pool (withResource, Pool)
 import Data.Profunctor.Product.Default
+import Data.Text qualified as T
 import Database.PostgreSQL.Simple qualified as PG
 import Database.PostgreSQL.Simple.Transaction qualified as PG
 import Gargantext.Database.Class
+import Gargantext.System.Logging (LogLevel, getLocTH, formatWithLoc, getLogger, logTxt, MonadLogger)
+import Language.Haskell.TH
 import Opaleye
 import Prelude
 
+data LogMessage =
+  LogMessage
+    { _lm_severity :: LogLevel
+    , _lm_msg      :: T.Text
+    }
+
+txLogLocM :: ExpQ
+txLogLocM = [| \level msg ->
+  let loc = $(getLocTH)
+  in DBTx . liftF $ DBLogMessage (LogMessage level (formatWithLoc loc msg)) id
+  |]
+
 data DBTxException err
   = RollbackRequested err
   deriving (Show, Eq)
@@ -127,6 +146,9 @@ data DBTransactionOp err (r :: DBOperation) next where
   OpaDelete :: Delete a -> (a -> next) -> DBTransactionOp err DBWrite next
   -- | Monadic failure for DB transactions.
   DBFail    :: err -> DBTransactionOp err r next
+  -- | Emits a log message. Log messages are collected in a pure setting and emitted while interpreting
+  -- the monad.
+  DBLogMessage :: LogMessage -> (() -> next) -> DBTransactionOp err r next
 
 -- | A 'DBTx' is a free monad (using the free church-encoding 'F') using 'DBTransactionOp' as the functor.
 -- In practical terms, it's just a monad where we can execute just the operations described by the
@@ -141,7 +163,13 @@ type DBReadOnly err r a = DBTx err DBRead a
 -- Strict constraints to perform transactional read and writes.
 -- Isomorphic to a DBCmd, but it doesn't impose a 'HasConfig' constraint, as
 -- values can always be passed as parameters of a query or update.
-type DBTxCmd err a = forall m env. (IsCmd env err m, HasConnectionPool env, Safe.MonadCatch m) => m a
+type DBTxCmd err a =
+  forall m env. (
+      IsCmd env err m
+    , HasConnectionPool env
+    , Safe.MonadCatch m
+    , MonadLogger m
+    ) => m a
 
 instance Functor (DBTransactionOp err r) where
   fmap f = \case
@@ -155,6 +183,7 @@ instance Functor (DBTransactionOp err r) where
     OpaUpdate upd cont             -> OpaUpdate upd      (f . cont)
     OpaDelete del cont             -> OpaDelete del      (f . cont)
     DBFail    err                  -> DBFail err
+    DBLogMessage msg cont          -> DBLogMessage msg (f . cont)
 
 -- | Generalised version of 'withResource' to work over any unlifted monad.
 -- For some reason 'resource-pool' removed this from version 0.3.0.0 onwards.
@@ -229,6 +258,9 @@ evalOp conn = \case
   OpaUpdate upd  cc             -> cc <$> liftBase (runUpdate conn upd)
   OpaDelete del  cc             -> cc <$> liftBase (runDelete conn del)
   DBFail    err                 -> liftBase (Safe.throwIO $ RollbackRequested err)
+  DBLogMessage (LogMessage sev msg) cc -> cc <$> do
+    lgr <- getLogger
+    logTxt lgr sev msg
 
 evalOpaCountQuery :: PG.Connection -> Select a -> IO Int
 evalOpaCountQuery conn sel = do

src/Gargantext/System/Logging.hs

@@ -10,6 +10,10 @@ module Gargantext.System.Logging (
   , logLoc
   , withLogger
   , withLoggerIO
+
+  -- * Internals
+  , getLocTH
+  , formatWithLoc
   ) where
 
 import Gargantext.System.Logging.Types