Merge branch 'adinapoli/issue-499' into 'dev'

Add the ability to emit logging messages from a `DbTx` transaction

Closes #499

See merge request !436

bin/gargantext-cli/CLI/Admin.hs

+{-# LANGUAGE ConstraintKinds #-}
 
 module CLI.Admin (
     adminCLI
@@ -17,11 +18,14 @@ import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Options.Applicative
 import Prelude (String)
+import Control.Monad.Random
+
+type DBCmdWithRandom env err a = forall m. (IsDBEnvExtra env, MonadRandom m, IsDBCmd env err m) => m a
 
 adminCLI :: AdminArgs -> IO ()
 adminCLI (AdminArgs settingsPath mails) = do
   withDevEnv settingsPath $ \env -> do
-    x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: CmdRandom DevEnv BackendInternalError (NonEmpty UserId))
+    x <- runCmdDev' env ((newUsers $ NE.map cs (NE.fromList mails)) :: DBCmdWithRandom DevEnv BackendInternalError (NonEmpty UserId))
     putStrLn (show x :: Text)
 
 adminCmd :: HasCallStack => Mod CommandFields CLI

bin/gargantext-cli/CLI/Init.hs

@@ -18,7 +18,7 @@ module CLI.Init where
 import CLI.Parsers
 import CLI.Types
 import Data.List.NonEmpty qualified as NE
-import Gargantext.API.Dev (withDevEnv, runCmdDev)
+import Gargantext.API.Dev (withDevEnv, runCmdDev')
 import Gargantext.API.Errors.Types
 import Gargantext.API.Node () -- instances only
 import Gargantext.Core.Config (GargConfig(..))
@@ -70,7 +70,7 @@ initCLI (InitArgs settingsPath) = do
       pure (masterUserId, masterRootId, masterCorpusId, masterListId)
 
   withDevEnv settingsPath $ \env -> do
-    x <- runCmdDev env $ runDBTx $ do
+    x <- runCmdDev' env $ runDBTx $ do
       _ <- initFirstTriggers secret
       _ <- createUsers
       x' <- initMaster

bin/gargantext-cli/CLI/Invitations.hs

@@ -17,7 +17,7 @@ module CLI.Invitations where
 import CLI.Parsers
 import CLI.Types
 import Control.Monad.Random (MonadRandom)
-import Gargantext.API.Dev (withDevEnv, runCmdDev)
+import Gargantext.API.Dev (withDevEnv, runCmdDev')
 import Gargantext.API.Errors.Types
 import Gargantext.API.Node () -- instances only
 import Gargantext.API.Node.Share qualified as Share
@@ -26,6 +26,7 @@ import Gargantext.Core.Types
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Prelude (IsDBCmdExtra)
 import Gargantext.Prelude
+import Gargantext.System.Logging.Types
 import Options.Applicative
 import Prelude (String)
 
@@ -33,12 +34,12 @@ invitationsCLI :: InvitationsArgs -> IO ()
 invitationsCLI (InvitationsArgs settingsPath user node_id email) = do
   -- _cfg       <- readConfig settingsPath
 
-  let invite :: (IsDBCmdExtra env BackendInternalError m, MonadRandom m)
+  let invite :: (IsDBCmdExtra env BackendInternalError m, MonadRandom m, MonadLogger m)
              => m Int
       invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email)
 
   withDevEnv settingsPath $ \env -> do
-    void $ runCmdDev env invite
+    void $ runCmdDev' env invite
 
 invitationsCmd :: HasCallStack => Mod CommandFields CLI
 invitationsCmd = command "invitations" (info (helper <*> fmap CLISub invitations_p) (progDesc "Mailing invitations."))

src/Gargantext/API.hs

@@ -30,11 +30,13 @@ Pouillard (who mainly made it).
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Gargantext.API
       where
 
 import Control.Concurrent.Async qualified as Async
+import Control.Exception.Safe qualified as Safe
 import Data.Cache qualified as InMemory
 import Data.List (lookup)
 import Data.Set qualified as Set
@@ -66,6 +68,7 @@ import Servant hiding (Header)
 import Servant.Client.Core.BaseUrl (showBaseUrl, baseUrlPort)
 import System.Clock qualified as Clock
 import System.Cron.Schedule qualified as Cron
+import Gargantext.API.Errors.Types (BackendInternalError (..))
 
 -- | startGargantext takes as parameters port number and Toml file.
 startGargantext :: Mode -> SettingsFile -> IO ()
@@ -93,16 +96,18 @@ startGargantext mode sf@(SettingsFile settingsFile) = do
             let runProxy  = run proxyPort (mid (microServicesProxyApp proxyCache env))
             Async.race_ runServer runProxy
 
-  where runDbCheck env = do
-          r <- runExceptT (runReaderT DB.dbCheck env) `catch`
-            (\(err :: SomeException) -> pure $ Left err)
-          case r of
-            Right True  -> pure ()
-            Right False -> panicTrace $
-              "You must run 'gargantext init -c " <> pack settingsFile <>
-              "' before running gargantext-server (only the first time)."
-            Left err -> panicTrace $ "Unexpected exception:" <> show err
-        oneHour = Clock.fromNanoSecs 3600_000_000_000
+  where
+    runDbCheck :: Env -> IO ()
+    runDbCheck env = do
+      r <- (runExceptT @BackendInternalError (runReaderT DB.dbCheck env)) `Safe.catch`
+        (\(err :: SomeException) -> pure $ Left $ InternalUnexpectedError err)
+      case r of
+        Right True  -> pure ()
+        Right False -> panicTrace $
+          "You must run 'gargantext init -c " <> pack settingsFile <>
+          "' before running gargantext-server (only the first time)."
+        Left err -> panicTrace $ "Unexpected exception:" <> show err
+    oneHour = Clock.fromNanoSecs 3600_000_000_000
 
 startupInfo :: GargConfig -> PortNumber -> MicroServicesProxyStatus -> IO ()
 startupInfo config mainPort proxyStatus = do

src/Gargantext/API/Admin/Auth.hs

@@ -239,8 +239,8 @@ forgotPasswordPost :: (IsDBEnvExtra env)
 forgotPasswordPost (ForgotPasswordRequest _email) = do
   pure $ ForgotPasswordResponse "ok"
 
-forgotPasswordGet :: (IsDBEnvExtra env, HasServerError err)
-     => Maybe Text -> Cmd env err ForgotPasswordGet
+forgotPasswordGet :: (IsDBEnvExtra env, IsDBTxCmd env err m, HasServerError err)
+     => Maybe Text -> m ForgotPasswordGet
 forgotPasswordGet Nothing = pure $ ForgotPasswordGet ""
 forgotPasswordGet (Just uuid) = do
   let mUuid = fromText uuid
@@ -256,8 +256,7 @@ forgotPasswordGet (Just uuid) = do
 
 ---------------------
 
-forgotPasswordGetUser :: ( IsDBEnvExtra env)
-     => UserLight -> Cmd env err ForgotPasswordGet
+forgotPasswordGetUser :: (IsDBEnvExtra env, IsDBTxCmd env err m) => UserLight -> m ForgotPasswordGet
 forgotPasswordGetUser (UserLight { .. }) = do
   -- pick some random password
   password <- liftBase gargPass
@@ -273,8 +272,7 @@ forgotPasswordGetUser (UserLight { .. }) = do
 
   pure $ ForgotPasswordGet password
 
-forgotUserPassword :: (IsDBEnvExtra env)
-     => UserLight -> Cmd env err ()
+forgotUserPassword :: (IsDBEnvExtra env, IsDBTxCmd env err m) => UserLight -> m ()
 forgotUserPassword (UserLight { .. }) = do
   --printDebug "[forgotUserPassword] userLight_id" userLight_id
   --logDebug $ "[forgotUserPassword]" :# ["userLight_id" .= userLight_id]
@@ -298,8 +296,7 @@ forgotUserPassword (UserLight { .. }) = do
 --------------------------
 
 -- Generate a unique (in whole DB) UUID for passwords.
-generateForgotPasswordUUID :: (IsDBEnvExtra env)
-  => Cmd env err UUID
+generateForgotPasswordUUID :: (IsDBEnvExtra env, IsDBTxCmd env err m) => m UUID
 generateForgotPasswordUUID = do
   uuid <- liftBase $ nextRandom
   us <- runDBQuery $ getUsersWithForgotPasswordUUID uuid

src/Gargantext/API/Dev.hs

+{-# OPTIONS_GHC -Wno-deprecations #-}
 {-|
 Module      : Gargantext.API.Dev
 Description :
@@ -24,7 +25,7 @@ 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 (mkNodeStoryEnv)
-import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd)
+import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd, DBCmdWithEnv)
 import Gargantext.Prelude
 import Gargantext.System.Logging ( withLoggerIO )
 import Network.HTTP.Client.TLS (newTlsManager)
@@ -69,6 +70,10 @@ runCmdDev :: (Typeable err, Show err) => DevEnv -> CmdRandom DevEnv err a -> IO
 runCmdDev env f =
   either (fail . show) pure =<< runCmd env f
 
+runCmdDev' :: (Typeable err, Show err) => env -> ReaderT env (ExceptT err IO) a -> IO a
+runCmdDev' env m =
+  either (fail . show) pure =<< (runExceptT (runReaderT m env))
+
 runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a
 runCmdGargDev env cmd =
   either (fail . show) pure =<< runExceptT (runReaderT cmd env)
@@ -82,6 +87,12 @@ runCmdDevServantErr = runCmdDev
 runCmdReplEasy :: CmdRandom DevEnv BackendInternalError a -> IO a
 runCmdReplEasy f = withDevEnv defaultSettingsFile $ \env -> runCmdDev env f
 
+runDBTxReplEasy :: DBCmdWithEnv DevEnv BackendInternalError a -> IO a
+runDBTxReplEasy f =
+  withDevEnv defaultSettingsFile $ \env -> either (fail . show) pure =<< run_it env f
+  where
+    run_it env m = runExceptT $ runReaderT m env
+
 -- | Execute a function that takes PSQL.Connection from the DB pool as
 --   first parameter.
 --   e.g.: runCmdReplEasyDB $ \c -> getNodeStory' c

src/Gargantext/API/GraphQL.hs

@@ -19,12 +19,12 @@ Portability : POSIX
 
 module Gargantext.API.GraphQL where
 
+-- import Data.Proxy
 import Data.ByteString.Lazy.Char8 ( ByteString )
 import Data.Morpheus ( App, deriveApp )
 import Data.Morpheus.Server ( httpPlayground )
 import Data.Morpheus.Subscriptions ( Event (..), httpPubApp )
 import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..), Undefined, defaultRootResolver)
--- import Data.Proxy
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
 import Gargantext.API.Auth.PolicyCheck
 import Gargantext.API.Errors.Types
@@ -35,6 +35,7 @@ import Gargantext.API.GraphQL.NLP qualified as GQLNLP
 import Gargantext.API.GraphQL.Node qualified as GQLNode
 import Gargantext.API.GraphQL.Team qualified as GQLTeam
 import Gargantext.API.GraphQL.TreeFirstLevel qualified as GQLTree
+import Gargantext.API.GraphQL.Types (GqlLogger)
 import Gargantext.API.GraphQL.User qualified as GQLUser
 import Gargantext.API.GraphQL.UserInfo qualified as GQLUserInfo
 import Gargantext.API.Prelude (GargM)
@@ -97,7 +98,7 @@ data Contet m
 -- | The main GraphQL resolver: how queries, mutations and
 -- subscriptions are handled.
 rootResolver
-  :: (IsDBEnvExtra env, HasNLPServer env, HasJWTSettings env)
+  :: (IsDBEnvExtra env, HasNLPServer env, HasJWTSettings env, GqlLogger env)
   => AuthenticatedUser
   -> AccessPolicyManager
   -> RootResolver (GargM env BackendInternalError) e Query Mutation Undefined
@@ -128,7 +129,7 @@ rootResolver authenticatedUser policyManager =
 
 -- | Main GraphQL "app".
 app
-  :: (Typeable env, IsDBEnvExtra env, HasNLPServer env, HasJWTSettings env)
+  :: (Typeable env, IsDBEnvExtra env, HasNLPServer env, HasJWTSettings env, GqlLogger env)
   => AuthenticatedUser
   -> AccessPolicyManager
   -> App (EVENT (GargM env BackendInternalError)) (GargM env BackendInternalError)
@@ -166,7 +167,7 @@ data GraphQLAPIEndpoints mode = GraphQLAPIEndpoints
 
 -- | Implementation of our API.
 api
-  :: (Typeable env, IsDBEnvExtra env, HasJWTSettings env)
+  :: (Typeable env, IsDBEnvExtra env, HasJWTSettings env, GqlLogger env)
   => GraphQLAPI (AsServerT (GargM env BackendInternalError))
 api = GraphQLAPI $ \case
   (SAS.Authenticated auser)

src/Gargantext/API/GraphQL/Annuaire.hs

@@ -27,7 +27,7 @@ import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Context (getContextWith)
 import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Prelude
-import Gargantext.API.GraphQL.Types (GqlM)
+import Gargantext.API.GraphQL.Types (GqlM, GqlLogger)
 
 data AnnuaireContact = AnnuaireContact
   { ac_title        :: !(Maybe Text)
@@ -55,13 +55,13 @@ data AnnuaireContactArgs
 
 -- | Function to resolve user from a query.
 resolveAnnuaireContacts
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => AnnuaireContactArgs -> GqlM e env [AnnuaireContact]
 resolveAnnuaireContacts AnnuaireContactArgs { contact_id } = dbAnnuaireContacts contact_id
 
 -- | Inner function to fetch the user from DB.
 dbAnnuaireContacts
-  :: IsDBEnvExtra env
+  :: (IsDBEnvExtra env, GqlLogger env)
   => Int -> GqlM e env [AnnuaireContact]
 dbAnnuaireContacts contact_id = do
   -- lift $ printDebug "[dbUsers]" user_id

src/Gargantext/API/GraphQL/Context.hs

@@ -11,6 +11,7 @@ Portability : POSIX
 
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ConstraintKinds #-}
 
 module Gargantext.API.GraphQL.Context where
 
@@ -22,6 +23,7 @@ import Data.Morpheus.Types
   , ResolverM
   , QUERY
   )
+
 import Data.Text (pack)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
@@ -38,6 +40,7 @@ import Gargantext.Database.Query.Table.NodeContext qualified as DNC
 import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Hash (Hash)
+import Gargantext.System.Logging (MonadLogger)
 
 data ContextGQL = ContextGQL
   { c_id        :: Int
@@ -111,6 +114,7 @@ data ContextNgramsArgs
     , list_id     :: Int }
     deriving (Generic, GQLType)
 
+type GqlLogger env = MonadLogger (GargM env BackendInternalError)
 type GqlM e env = Resolver QUERY e (GargM env BackendInternalError)
 type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
 
@@ -118,19 +122,19 @@ type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
 
 -- | Function to resolve context from a query.
 resolveNodeContext
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => NodeContextArgs -> GqlM e env [NodeContextGQL]
 resolveNodeContext NodeContextArgs { context_id, node_id } =
   dbNodeContext context_id node_id
 
 resolveContextsForNgrams
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => ContextsForNgramsArgs -> GqlM e env [ContextGQL]
 resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_terms, and_logic } =
   dbContextForNgrams corpus_id ngrams_terms and_logic
 
 resolveContextNgrams
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => ContextNgramsArgs -> GqlM e env [Text]
 resolveContextNgrams ContextNgramsArgs { context_id, list_id } =
   dbContextNgrams context_id list_id
@@ -139,7 +143,7 @@ resolveContextNgrams ContextNgramsArgs { context_id, list_id } =
 
 -- | Inner function to fetch the node context DB.
 dbNodeContext
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => Int -> Int -> GqlM e env [NodeContextGQL]
 dbNodeContext context_id node_id = do
   -- lift $ printDebug "[dbUsers]" user_id
@@ -151,7 +155,7 @@ dbNodeContext context_id node_id = do
 
 -- | Returns list of `ContextGQL` for given ngrams in given corpus id.
 dbContextForNgrams
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => Int -> [Text] -> Bool -> GqlM e env [ContextGQL]
 dbContextForNgrams node_id ngrams_terms and_logic = do
   contextsForNgramsTerms <- lift $ runDBQuery $
@@ -161,7 +165,7 @@ dbContextForNgrams node_id ngrams_terms and_logic = do
 
 -- | Fetch ngrams matching given context in a given list id.
 dbContextNgrams
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => Int -> Int -> GqlM e env [Text]
 dbContextNgrams context_id list_id = do
   lift $ runDBQuery $ getContextNgramsMatchingFTS (UnsafeMkContextId context_id) (UnsafeMkNodeId list_id)
@@ -221,7 +225,7 @@ toHyperdataRowDocumentGQL hyperdata =
                                      }
     HyperdataRowContact { } -> Nothing
 
-updateNodeContextCategory :: (IsDBEnvExtra env)
+updateNodeContextCategory :: (IsDBEnvExtra env, GqlLogger env)
                           => AuthenticatedUser
                           -> AccessPolicyManager
                           -> NodeContextCategoryMArgs

src/Gargantext/API/GraphQL/Node.hs

@@ -20,7 +20,7 @@ import Data.Morpheus.Types ( GQLType )
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
 import Gargantext.API.Auth.PolicyCheck ( nodeReadChecks, AccessPolicyManager )
 import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
-import Gargantext.API.GraphQL.Types ( GqlM )
+import Gargantext.API.GraphQL.Types ( GqlM, GqlLogger )
 import Gargantext.Core ( HasDBid(lookupDBid) )
 import Gargantext.Database.Admin.Types.Node (NodeType)
 import Gargantext.Database.Admin.Types.Node qualified as NN
@@ -57,7 +57,7 @@ data NodeArgs
 
 -- | Function to resolve user from a query.
 resolveNodes
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => AuthenticatedUser
   -> AccessPolicyManager
   -> NodeArgs
@@ -66,19 +66,19 @@ resolveNodes autUser mgr NodeArgs { node_id } =
   withPolicy autUser mgr (nodeReadChecks $ NN.UnsafeMkNodeId node_id) $ dbNodes node_id
 
 resolveNodesCorpus
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => CorpusArgs -> GqlM e env [Corpus]
 resolveNodesCorpus CorpusArgs { corpus_id } = dbNodesCorpus corpus_id
 
 dbNodes
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => Int -> GqlM e env [Node]
 dbNodes node_id = do
   node <- lift $ runDBQuery $ getNode $ NN.UnsafeMkNodeId node_id
   pure [toNode node]
 
 dbNodesCorpus
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => Int -> GqlM e env [Corpus]
 dbNodesCorpus corpus_id = do
   corpus <- lift $ runDBQuery $ getNode $ NN.UnsafeMkNodeId corpus_id
@@ -97,17 +97,17 @@ data NodeChildrenArgs
     } deriving (Generic, GQLType)
 
 resolveNodeParent
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => NodeParentArgs -> GqlM e env [Node]
 resolveNodeParent NodeParentArgs { node_id, parent_type } = dbParentNodes node_id parent_type
 
 resolveNodeChildren
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => NodeChildrenArgs -> GqlM e env [Node]
 resolveNodeChildren NodeChildrenArgs { node_id, child_type } = dbChildNodes node_id child_type
 
 dbParentNodes
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => Int -> NodeType -> GqlM e env [Node]
 dbParentNodes node_id parentType = do
   -- let mParentType = readEither (T.unpack parent_type) :: Either Prelude.String NodeType
@@ -124,7 +124,7 @@ dbParentNodes node_id parentType = do
           node <- getNode id
           pure [toNode node]
 
-dbChildNodes :: (IsDBEnvExtra env)
+dbChildNodes :: (IsDBEnvExtra env, GqlLogger env)
              => Int -> NodeType -> GqlM e env [Node]
 dbChildNodes node_id childType = do
   lift $ runDBQuery $ do

src/Gargantext/API/GraphQL/PolicyCheck.hs

@@ -16,16 +16,17 @@ import Prelude
 
 import Control.Monad.Except (MonadError(..))
 import Control.Monad.Trans.Class (lift)
+import Data.Morpheus.App.Internal.Resolving (LiftOperation)
+import Data.Morpheus.Types (ResolverO)
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
 import Gargantext.API.Auth.PolicyCheck ( BoolExpr, AccessCheck, AccessPolicyManager(..), AccessResult(..))
 import Gargantext.API.Errors.Types ( BackendInternalError(..) )
+import Gargantext.API.GraphQL.Types (GqlLogger)
+import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Config (HasConfig)
 import Gargantext.Database.Prelude (HasConnectionPool)
-import Data.Morpheus.Types (ResolverO)
-import Data.Morpheus.App.Internal.Resolving (LiftOperation)
-import Gargantext.API.Prelude (GargM)
 
-withPolicy :: (HasConnectionPool env, HasConfig env, LiftOperation op)
+withPolicy :: (HasConnectionPool env, HasConfig env, LiftOperation op, GqlLogger env)
            => AuthenticatedUser
            -> AccessPolicyManager
            -> BoolExpr AccessCheck

src/Gargantext/API/GraphQL/Team.hs

@@ -18,7 +18,7 @@ import Data.Morpheus.Types (GQLType, ResolverM)
 import Data.Text qualified as T
 import Gargantext.API.Admin.Auth.Types (AuthenticationError(..))
 import Gargantext.API.Errors.Types
-import Gargantext.API.GraphQL.Types (GqlM)
+import Gargantext.API.GraphQL.Types (GqlM, GqlLogger)
 import Gargantext.API.GraphQL.Utils (authUser, AuthStatus (Invalid, Valid))
 import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Config (HasJWTSettings)
@@ -53,10 +53,10 @@ data TeamDeleteMArgs = TeamDeleteMArgs
 
 type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a
 
-resolveTeam :: (IsDBEnvExtra env) => TeamArgs -> GqlM e env Team
+resolveTeam :: (IsDBEnvExtra env, GqlLogger env) => TeamArgs -> GqlM e env Team
 resolveTeam TeamArgs { team_node_id } = dbTeam team_node_id
 
-dbTeam :: (IsDBEnvExtra env) =>
+dbTeam :: (IsDBEnvExtra env, GqlLogger env) =>
           Int -> GqlM e env Team
 dbTeam nodeId = do
   let nId = UnsafeMkNodeId nodeId
@@ -79,7 +79,7 @@ dbTeam nodeId = do
     getUsername ((UserLight {userLight_username}, _):_) = userLight_username
 
 -- TODO: list as argument
-deleteTeamMembership :: (IsDBEnvExtra env, HasJWTSettings env) =>
+deleteTeamMembership :: (IsDBEnvExtra env, HasJWTSettings env, GqlLogger env) =>
                         TeamDeleteMArgs -> GqlM' e env [Int]
 deleteTeamMembership TeamDeleteMArgs { token, shared_folder_id, team_node_id } = do
   userNodes <- lift $ runDBTx $ do

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

@@ -18,7 +18,7 @@ import Data.Morpheus.Types (GQLType)
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(..) )
 import Gargantext.API.Auth.PolicyCheck (AccessPolicyManager, nodeReadChecks)
 import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
-import Gargantext.API.GraphQL.Types ( GqlM )
+import Gargantext.API.GraphQL.Types ( GqlM, GqlLogger )
 import Gargantext.Core (fromDBid)
 -- import Gargantext.Core.Types (ContextId, CorpusId, ListId)
 import Gargantext.Core.Types.Main ( Tree(..), _tn_node, _tn_children, NodeTree(..), _nt_name )
@@ -65,7 +65,7 @@ data BreadcrumbInfo = BreadcrumbInfo
 
 type ParentId = Maybe NodeId
 
-resolveTree :: (IsDBEnvExtra env)
+resolveTree :: (IsDBEnvExtra env, GqlLogger env)
             => AuthenticatedUser
             -> AccessPolicyManager
             -> TreeArgs
@@ -73,7 +73,7 @@ resolveTree :: (IsDBEnvExtra env)
 resolveTree autUser mgr TreeArgs { root_id } =
   withPolicy autUser mgr (nodeReadChecks $ UnsafeMkNodeId root_id) $ dbTree (_auth_user_id autUser) root_id
 
-dbTree :: (IsDBEnvExtra env) =>
+dbTree :: (IsDBEnvExtra env, GqlLogger env) =>
           NN.UserId -> Int -> GqlM e env (TreeFirstLevel (GqlM e env))
 dbTree loggedInUserId root_id = do
   let rId = UnsafeMkNodeId root_id
@@ -86,7 +86,7 @@ dbTree loggedInUserId root_id = do
     toParentId N.Node { _node_parent_id } = _node_parent_id
 
 
-toTree :: (IsDBEnvExtra env) => NodeId -> ParentId -> Tree NodeTree -> TreeFirstLevel (GqlM e env)
+toTree :: (IsDBEnvExtra env, GqlLogger env) => NodeId -> ParentId -> Tree NodeTree -> TreeFirstLevel (GqlM e env)
 toTree rId pId TreeN { _tn_node, _tn_children } = TreeFirstLevel
   { parent   = resolveParent pId
   , root     = toTreeNode pId _tn_node
@@ -99,7 +99,7 @@ toTreeNode pId NodeTree { _nt_name, _nt_id, _nt_type } = TreeNode { name = _nt_n
 childrenToTreeNodes :: (Tree NodeTree, NodeId) -> TreeNode
 childrenToTreeNodes (TreeN {_tn_node}, rId) = toTreeNode (Just rId) _tn_node
 
-resolveParent :: (IsDBEnvExtra env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
+resolveParent :: (IsDBEnvExtra env, GqlLogger env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
 resolveParent (Just pId) = do
   node <- lift $ runDBQuery $ getNode pId
   pure $ nodeToTreeNode node
@@ -118,7 +118,7 @@ nodeToTreeNode N.Node {..} =
    else
      Nothing
 
-resolveBreadcrumb :: (IsDBEnvExtra env) => BreadcrumbArgs -> GqlM e env BreadcrumbInfo
+resolveBreadcrumb :: (IsDBEnvExtra env, GqlLogger env) => BreadcrumbArgs -> GqlM e env BreadcrumbInfo
 resolveBreadcrumb BreadcrumbArgs { node_id } = dbRecursiveParents node_id
 
 convertDbTreeToTreeNode :: HasCallStack => T.DbTreeNode -> TreeNode
@@ -131,7 +131,7 @@ convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_par
     }
 
 
-dbRecursiveParents :: (IsDBEnvExtra env) => Int -> GqlM e env BreadcrumbInfo
+dbRecursiveParents :: (IsDBEnvExtra env, GqlLogger env) => Int -> GqlM e env BreadcrumbInfo
 dbRecursiveParents nodeId = do
   let nId = UnsafeMkNodeId nodeId
   dbParents <- lift $ runDBQuery $ T.recursiveParents nId allNodeTypes

src/Gargantext/API/GraphQL/Types.hs

+{-# LANGUAGE ConstraintKinds #-}
 
 module Gargantext.API.GraphQL.Types where
 
 import Data.Morpheus.Types
-import Gargantext.API.Prelude
 import Gargantext.API.Errors.Types
+import Gargantext.API.Prelude
+import Gargantext.System.Logging
 
+type GqlLogger env = MonadLogger (GargM env BackendInternalError)
 type GqlM e env = Resolver QUERY e (GargM env BackendInternalError)
 type GqlM' e env a = ResolverM e (GargM env BackendInternalError) a

src/Gargantext/API/GraphQL/User.hs

@@ -18,7 +18,7 @@ import Data.Morpheus.Types ( GQLType )
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
 import Gargantext.API.Auth.PolicyCheck (AccessPolicyManager, nodeReadChecks)
 import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
-import Gargantext.API.GraphQL.Types (GqlM, GqlM')
+import Gargantext.API.GraphQL.Types (GqlM, GqlM', GqlLogger)
 import Gargantext.Core.Types (NodeId(..), UserId)
 import Gargantext.Core.Types.Individu qualified as Individu
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..))
@@ -60,7 +60,7 @@ data UserEPOAPITokenMArgs
 
 -- | Function to resolve user from a query.
 resolveUsers
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => AuthenticatedUser
   -> AccessPolicyManager
   -> UserArgs
@@ -70,12 +70,12 @@ resolveUsers autUser mgr UserArgs { user_id } = do
   withPolicy autUser mgr (nodeReadChecks $ UnsafeMkNodeId user_id) $ dbUsers user_id
 
 -- | Inner function to fetch the user from DB.
-dbUsers :: (IsDBEnvExtra env)
+dbUsers :: (IsDBEnvExtra env, GqlLogger env)
         => Int -> GqlM e env [User (GqlM e env)]
 dbUsers user_id = lift (map toUser <$> runDBQuery (DBUser.getUsersWithId (Individu.RootId $ UnsafeMkNodeId user_id)))
 
 toUser
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => UserLight -> User (GqlM e env)
 toUser (UserLight { .. }) = User { u_email = userLight_email
                                  , u_hyperdata = resolveHyperdata userLight_id
@@ -83,25 +83,25 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
                                  , u_username = userLight_username }
 
 resolveHyperdata
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => UserId -> GqlM e env (Maybe HyperdataUser)
 resolveHyperdata userid = lift (listToMaybe <$> runDBQuery (DBUser.getUserHyperdata (Individu.UserDBId userid)))
 
-updateUserPubmedAPIKey :: ( IsDBEnvExtra env ) =>
+updateUserPubmedAPIKey :: ( IsDBEnvExtra env, GqlLogger env ) =>
                           UserPubmedAPIKeyMArgs -> GqlM' e env Int
 updateUserPubmedAPIKey UserPubmedAPIKeyMArgs { user_id, api_key } = do
   _ <- lift $ runDBTx $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ UnsafeMkNodeId user_id) api_key
 
   pure 1
 
-updateUserEPOAPIUser :: ( IsDBEnvExtra env ) =>
+updateUserEPOAPIUser :: ( IsDBEnvExtra env, GqlLogger env ) =>
                         UserEPOAPIUserMArgs -> GqlM' e env Int
 updateUserEPOAPIUser UserEPOAPIUserMArgs { user_id, api_user } = do
   _ <- lift $ runDBTx $ DBUser.updateUserEPOAPIUser (Individu.RootId $ UnsafeMkNodeId user_id) api_user
 
   pure 1
 
-updateUserEPOAPIToken :: ( IsDBEnvExtra env ) =>
+updateUserEPOAPIToken :: ( IsDBEnvExtra env, GqlLogger env ) =>
                          UserEPOAPITokenMArgs -> GqlM' e env Int
 updateUserEPOAPIToken UserEPOAPITokenMArgs { user_id, api_token } = do
   _ <- lift $ runDBTx $ DBUser.updateUserEPOAPIToken (Individu.RootId $ UnsafeMkNodeId user_id) api_token

src/Gargantext/API/GraphQL/UserInfo.hs

@@ -44,7 +44,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
 import Gargantext.API.Auth.PolicyCheck (AccessPolicyManager, userMe)
 import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
-import Gargantext.API.GraphQL.Types (GqlM, GqlM')
+import Gargantext.API.GraphQL.Types (GqlM, GqlM', GqlLogger)
 import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser)
 import Gargantext.Core.Config (HasJWTSettings)
 import Gargantext.Core.Types (UserId(..))
@@ -109,7 +109,7 @@ data UserInfoMArgs
 
 -- | Function to resolve user from a query.
 resolveUserInfos
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => AuthenticatedUser
   -> AccessPolicyManager
   -> UserInfoArgs -> GqlM e env [UserInfo]
@@ -119,7 +119,7 @@ resolveUserInfos autUser mgr UserInfoArgs { user_id } =
 
 -- | Mutation for user info
 updateUserInfo
-  :: (IsDBEnvExtra env, HasJWTSettings env)
+  :: (IsDBEnvExtra env, HasJWTSettings env, GqlLogger env)
   -- => UserInfoMArgs -> ResolverM e (GargM env err) Int
   => UserInfoMArgs -> GqlM' e env Int
 updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
@@ -169,7 +169,7 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
 
 -- | Inner function to fetch the user from DB.
 dbUsers
-  :: (IsDBEnvExtra env)
+  :: (IsDBEnvExtra env, GqlLogger env)
   => UserId -> GqlM e env [UserInfo]
 dbUsers user_id = do
   -- lift $ printDebug "[dbUsers]" user_id

src/Gargantext/API/Ngrams.hs

@@ -22,7 +22,8 @@ add get
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE TemplateHaskell     #-}
 
 
 module Gargantext.API.Ngrams
@@ -118,6 +119,7 @@ import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFas
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Ngrams ( text2ngrams, insertNgrams )
 import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
+import Gargantext.System.Logging.Types (LogLevel(DEBUG))
 import Text.Collate qualified as Unicode
 
 
@@ -569,6 +571,7 @@ getNgramsTable' env nId listId ngramsType = do
 -- | Helper function to set scores on an `NgramsTable`.
 setNgramsTableScores :: forall err t x.
                         ( Each t t NgramsElement NgramsElement
+                        , Show t
                         )
                      => NodeId
                      -> ListId
@@ -579,21 +582,18 @@ setNgramsTableScores nId listId ngramsType table = do
   -- FIXME(adn) RESTORE these!
   --t1 <- getTime
   occurrences <- getOccByNgramsOnlyFast nId listId ngramsType
-  --printDebug "[setNgramsTableScores] occurrences" occurrences
+  $(txLogLocM) DEBUG $ "occurrences: " <> T.pack (show occurrences)
   --t2 <- getTime
-  -- let ngrams_terms = table ^.. each . ne_ngrams
-  -- $(logLocM) DEBUG $ "ngrams_terms: " <> show ngrams_terms
-  -- $(logLocM) DEBUG $ sformat ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n") (length ngrams_terms) t1 t2
-  let
-    setOcc ne = ne & ne_occurrences .~ Set.fromList (msumOf (ix (ne ^. ne_ngrams)) occurrences)
+  let ngrams_terms = table ^.. each . ne_ngrams
+  $(txLogLocM) DEBUG $ "ngrams_terms: " <> show ngrams_terms
+  -- $(txLogLocM) DEBUG $ sformat ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n") (length ngrams_terms) t1 t2
+  let setOcc ne = ne & ne_occurrences .~ Set.fromList (msumOf (ix (ne ^. ne_ngrams)) occurrences)
 
-  --printDebug "[setNgramsTableScores] with occurences" $ table & each %~ setOcc
+  $(txLogLocM) DEBUG $ "with occurences: " <> T.pack (show $ table & each %~ setOcc)
 
   pure $ table & each %~ setOcc
 
 
-
-
 -- APIs
 
 -- TODO: find a better place for the code above, All APIs stay here

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/API/Node/Corpus/Export/Utils.hs

@@ -81,7 +81,7 @@ getContextNgrams cId lId listType nt repo = do
 mkCorpusSQLiteData :: ( CES.MonadMask m
                       , HasNodeStoryEnv env err
                       , HasNodeError err
-                      , IsDBCmd env err m )
+                      , IsDBTxCmd env err m )
                    => CorpusId
                    -> Maybe ListId
                    -> m CorpusSQLiteData

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

@@ -163,15 +163,15 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
                                          , _wq_datafield = datafield
                                          , _wq_lang = l
                                          , _wq_flowListWith = flw }) maybeLimit jobHandle = do
-  -- TODO ...
-  $(logLocM) DEBUG $ "[addToCorpusWithQuery] cid " <> show cid
-  $(logLocM) DEBUG $ "[addToCorpusWithQuery] datafield  " <> show datafield
-  $(logLocM) DEBUG $ "[addToCorpusWithQuery] flowListWith " <> show flw
+  runDBTx $ do
+    $(txLogLocM) DEBUG $ "[addToCorpusWithQuery] cid " <> show cid
+    $(txLogLocM) DEBUG $ "[addToCorpusWithQuery] datafield  " <> show datafield
+    $(txLogLocM) DEBUG $ "[addToCorpusWithQuery] flowListWith " <> show flw
+
+    $(txLogLocM) DEBUG $ "[addToCorpusWithQuery] addLanguageToCorpus " <> show cid <> ", " <> show l
+    addLanguageToCorpus cid l
+    $(txLogLocM) DEBUG "[addToCorpusWithQuery] after addLanguageToCorpus"
 
-  $(logLocM) DEBUG $ "[addToCorpusWithQuery] addLanguageToCorpus " <> show cid <> ", " <> show l
-  runDBTx $ addLanguageToCorpus cid l
-  $(logLocM) DEBUG "[addToCorpusWithQuery] after addLanguageToCorpus"
-  
   case datafield of
     Web -> do
       $(logLocM) DEBUG $ "[addToCorpusWithQuery] processing web request " <> show datafield

src/Gargantext/API/Node/Share.hs

@@ -31,7 +31,7 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Database.Query.Tree (findNodesWithType)
 import Gargantext.Prelude
 import Servant.Server.Generic (AsServerT)
-import qualified Gargantext.Core.Notifications.CentralExchange.Types as CE
+import Gargantext.Core.Notifications.CentralExchange.Types qualified as CE
 
 ------------------------------------------------------------------------
 -- TODO permission

src/Gargantext/Core/Config/Utils.hs

@@ -14,13 +14,13 @@ module Gargantext.Core.Config.Utils (
   )
   where
 
+import Data.Text qualified as T
+import Gargantext.Core.Config
 import Gargantext.Core.Config.Types (SettingsFile(..))
 import Gargantext.Prelude
-import Toml
-import Gargantext.Core.Config
-import System.Environment (lookupEnv)
 import Gargantext.System.Logging.Types (parseLogLevel)
-import qualified Data.Text as T
+import System.Environment (lookupEnv)
+import Toml
 
 
 readConfig :: SettingsFile -> IO GargConfig

src/Gargantext/Core/Text/Corpus.hs

@@ -3,7 +3,7 @@ module Gargantext.Core.Text.Corpus (makeSubcorpusFromQuery, subcorpusEasy) where
 import Control.Lens (view)
 import Data.Set.Internal qualified as Set (singleton)
 import Data.Text qualified as T
-import Gargantext.API.Dev (runCmdReplEasy)
+import Gargantext.API.Dev (runDBTxReplEasy)
 import Gargantext.API.Errors.Types (BackendInternalError(InternalNodeError))
 import Gargantext.Core (Lang(EN))
 import Gargantext.Core.NodeStory.Types (HasNodeStoryEnv, hasNodeStory)
@@ -40,7 +40,7 @@ subcorpusEasy username cId rawQuery reuseParentList = do
   let eitherQuery = Q.parseQuery $ Q.RawQuery rawQuery
   case eitherQuery of
     Left msg -> print $ "Error parsing query \"" <> rawQuery <> "\": " <> T.pack msg
-    Right query -> void $ runCmdReplEasy $ makeSubcorpusFromQuery (UserName username) (UnsafeMkNodeId cId) query reuseParentList
+    Right query -> void $ runDBTxReplEasy $ makeSubcorpusFromQuery (UserName username) (UnsafeMkNodeId cId) query reuseParentList
 
 
 -- | Given a "parent" corpus and a query, search for all docs in the parent

src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs

@@ -42,7 +42,7 @@ import Gargantext.Prelude hiding (to)
 
 type MinSizeBranch = Int
 
-flowPhylo :: (HasNodeStory env err m, HasDBid NodeType, IsDBCmd env err m)
+flowPhylo :: (HasNodeStory env err m, HasDBid NodeType, IsDBTxCmd env err m)
           => CorpusId
           -> m Phylo
 flowPhylo cId = do

src/Gargantext/Database/Action/Flow.hs

@@ -341,8 +341,8 @@ addDocumentsToHyperCorpus mb_hyper la corpusId docs = do
   -- logged, but in the future they could be returned upstream so that we can
   -- display a final result of how many were skipped, how many succeded etc.
   uncommittedNgrams <- extractNgramsFromDocuments nlp la docs
-  ids <- runDBTx $ insertMasterDocs cfg uncommittedNgrams mb_hyper docs
   runDBTx $ do
+    ids <- insertMasterDocs cfg uncommittedNgrams mb_hyper docs
     void $ Doc.add corpusId (map nodeId2ContextId ids)
     pure ids
 

src/Gargantext/Database/Action/User/New.hs

@@ -27,8 +27,11 @@ module Gargantext.Database.Action.User.New
 
 import Control.Lens (view)
 import Control.Monad.Random
+import Data.List.NonEmpty qualified as NE
 import Data.Text (splitOn)
 import Data.Text qualified as Text
+import Gargantext.Core.Config (HasConfig(..))
+import Gargantext.Core.Config.Mail (MailConfig)
 import Gargantext.Core.Mail
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.Types.Individu
@@ -39,9 +42,6 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError,
 import Gargantext.Database.Query.Table.User
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Pass.User (gargPass)
-import Gargantext.Core.Config.Mail (MailConfig)
-import qualified Data.List.NonEmpty as NE
-import Gargantext.Core.Config (HasConfig(..))
 
 ------------------------------------------------------------------------
 -- | Creates a new 'User' from the input 'EmailAddress', which needs to

src/Gargantext/Database/Admin/Trigger/ContextNodeNgrams.hs

@@ -23,7 +23,7 @@ import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
 -- (ListId, CorpusId, NodeId)
 import Gargantext.Database.Prelude
 import Gargantext.Prelude
-import qualified Database.PostgreSQL.Simple as DPS
+import Database.PostgreSQL.Simple qualified as DPS
 
 triggerCountInsert :: HasDBid NodeType => DBUpdate err Int64
 triggerCountInsert = mkPGUpdate query (toDBid NodeDocument, toDBid NodeList)

src/Gargantext/Database/Admin/Trigger/NodesContexts.hs

@@ -23,7 +23,7 @@ import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
 import Gargantext.Database.Prelude
 import Gargantext.Prelude
-import qualified Database.PostgreSQL.Simple as DPS
+import Database.PostgreSQL.Simple qualified as DPS
 
 type MasterListId = ListId
 

src/Gargantext/Database/Class.hs

@@ -13,6 +13,7 @@ import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
 import Gargantext.Prelude
+import Gargantext.System.Logging.Types (MonadLogger)
 
 -- $typesAndConstraints
 --
@@ -77,6 +78,9 @@ type IsCmd env err m =
 type IsDBCmd env err m =
   ( IsCmd env err m
   , IsDBEnv env
+  -- Due to the fact that a 'DBCmd' is essentially a DBTxCmd but with the ability to acquire
+  -- a configuration, it makes sense for it to be able to emit logging messages.
+  , MonadLogger m
   )
 
 -- | Full-fledged command class. Types in this class provide commands that can
@@ -84,6 +88,7 @@ type IsDBCmd env err m =
 type IsDBCmdExtra env err m =
   ( IsCmd        env err m
   , IsDBEnvExtra env
+  , MonadLogger m
   )
 
 -- | Basic command with access to randomness. It feels a little ad hoc to have

src/Gargantext/Database/Prelude.hs

@@ -75,7 +75,6 @@ import Shelly qualified as SH
 import System.Directory (removeFile)
 import System.IO.Temp (emptySystemTempFile)
 
-
 type JSONB = DefaultFromField SqlJsonb
 
 -- FIXME(adinapoli): Using this function is dangerous and it should
@@ -91,7 +90,7 @@ withConn k = do
 
 runCmd :: (Show err, Typeable err)
        => env
-       -> CmdRandom env err a
+       -> ReaderT env (ExceptT err IO) a
        -> IO (Either err a)
 runCmd env m = runExceptT $ runReaderT m env
 

src/Gargantext/Database/Query/Table/Node.hs

@@ -73,6 +73,7 @@ import Control.Arrow (returnA)
 import Control.Lens (set, view)
 import Data.Aeson ( encode, Value )
 import Data.Bimap ((!>))
+import Data.List.NonEmpty qualified as NE
 import Database.PostgreSQL.Simple qualified as PGS
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Gargantext.API.Errors.Types (BackendInternalError (..))
@@ -93,7 +94,6 @@ import Gargantext.Database.Schema.Node
 import Gargantext.Prelude hiding (sum, head)
 import Opaleye hiding (FromField)
 import Prelude hiding (null, id, map, sum)
-import qualified Data.List.NonEmpty as NE
 
 
 queryNodeSearchTable :: Select NodeSearchRead

src/Gargantext/Database/Query/Table/NodeNode.hs

@@ -53,24 +53,24 @@ module Gargantext.Database.Query.Table.NodeNode
 
 import Control.Arrow (returnA)
 import Control.Lens (view)
+import Control.Lens qualified as L
+import Data.Text (splitOn)
 import Database.PostgreSQL.Simple qualified as PGS
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..), Only (..))
-import Data.Text (splitOn)
 import Gargantext.Core ( HasDBid(toDBid) )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument, hd_publication_date )
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude ( Hyperdata )
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node (getNode)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Schema.Ngrams ()
 import Gargantext.Database.Schema.Node
 import Gargantext.Database.Schema.NodeNode
 import Gargantext.Prelude
 import Opaleye
 import Opaleye qualified as O
-import qualified Control.Lens as L
 
 queryNodeNodeTable :: Select NodeNodeRead
 queryNodeNodeTable = selectTable nodeNodeTable

src/Gargantext/Database/Query/Table/User.hs

@@ -324,7 +324,7 @@ insertNewUsers newUsers = do
 -- | Insert into the DB users with a clear-text password after conversion
 -- via 'toUserHash'. This function is labeled \"unsafe\" because it doesn't
 -- compose as far as DB transactional safety.
-unsafeInsertHashNewUsers :: NonEmpty (NewUser GargPassword) -> DBCmd err Int64
+unsafeInsertHashNewUsers :: NonEmpty (NewUser GargPassword) -> DBTxCmd err Int64
 unsafeInsertHashNewUsers newUsers = do
   hashed <- liftBase $ mapM toUserHash newUsers
   runDBTx $ insertNewUsers hashed

src/Gargantext/Database/Transactional.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ConstraintKinds #-}
 
 {--| 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,
@@ -18,6 +20,7 @@ module Gargantext.Database.Transactional (
   , DBUpdate
   , DBQuery
   , DBTxCmd
+  , IsDBTxCmd
   -- * Executing queries and updates
   , runDBQuery
   , runDBTx
@@ -33,6 +36,9 @@ module Gargantext.Database.Transactional (
   , mkOpaInsert
   , mkOpaDelete
 
+  -- * Emitting log messages
+  , txLogLocM
+
   -- * Throwing and catching errors (which allows rollbacks)
   , dbFail
   , dbCheckOrFail
@@ -50,12 +56,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)
@@ -128,6 +149,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
@@ -142,7 +166,14 @@ 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. IsDBTxCmd env err m => m a
+
+type IsDBTxCmd env err m =
+  ( IsCmd env err m
+  , HasConnectionPool env
+  , Safe.MonadCatch m
+  , MonadLogger m
+  )
 
 instance Functor (DBTransactionOp err r) where
   fmap f = \case
@@ -156,6 +187,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.
@@ -230,6 +262,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

test/Test/Database/Transactions.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 {-| Tests for the transactional DB API -}
 
@@ -30,11 +32,16 @@ import Database.PostgreSQL.Simple.Options qualified as Client
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.ToField
 import Database.Postgres.Temp qualified as Tmp
+import Gargantext.Core.Config (LogConfig(..))
 import Gargantext.Core.Types.Individu
+import Gargantext.Database.Action.User
+import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Schema.Prelude (Table (..))
 import Gargantext.Database.Transactional
 import Gargantext.Prelude hiding (throwIO, catch)
+import Gargantext.System.Logging.Loggers
+import Gargantext.System.Logging.Types
 import Opaleye (selectTable, requiredTableField, SqlInt4)
 import Opaleye qualified as O
 import Prelude qualified
@@ -43,11 +50,9 @@ import System.Random.Stateful
 import Test.API.Setup (setupEnvironment)
 import Test.Database.Setup
 import Test.Database.Types hiding (Counter)
-import Test.Hspec
 import Test.HUnit hiding (assert)
+import Test.Hspec
 import Text.RawString.QQ
-import Gargantext.Database.Action.User
-import Gargantext.Database.Query.Table.Node.Error
 
 --
 -- For these tests we do not want to test the normal GGTX database queries, but rather
@@ -97,6 +102,23 @@ newtype TestDBTxMonad a = TestDBTxMonad { _TestDBTxMonad :: TestMonadM DBHandle
            , MonadThrow
            )
 
+instance HasLogger (TestMonadM DBHandle err) where
+  data instance Logger (TestMonadM DBHandle err)        = TestLogger1 { _IOLogger1 :: IOStdLogger }
+  type instance LogInitParams (TestMonadM DBHandle err) = LogConfig
+  type instance LogPayload (TestMonadM DBHandle err)    = Prelude.String
+  initLogger cfg = fmap TestLogger1 $ (liftIO $ ioStdLogger cfg)
+  destroyLogger = liftIO . _iosl_destroy . _IOLogger1
+  logMsg (TestLogger1 ioLogger) lvl msg = liftIO $ _iosl_log_msg ioLogger lvl msg
+  logTxt (TestLogger1 ioLogger) lvl msg = liftIO $ _iosl_log_txt ioLogger lvl msg
+
+instance MonadLogger (TestMonadM DBHandle IOException) where
+  getLogger = TestMonad $ do
+    initLogger @(TestMonadM DBHandle IOException) (LogConfig Nothing ERROR)
+
+instance MonadLogger (TestMonadM TestEnv NodeError) where
+  getLogger = TestMonad $ do
+    initLogger @(TestMonadM TestEnv NodeError) (LogConfig Nothing ERROR)
+
 runTestDBTxMonad :: DBHandle -> TestMonadM DBHandle IOException a -> IO a
 runTestDBTxMonad env m = do
   res <- flip runReaderT env . runExceptT . _TestMonad $ m