Merge branch 'dev' into 505-dev-search-query-performance-fix

CHANGELOG.md

+## Version 0.0.7.5.2
+
+* [BACK/FRONT][FIX][[query] a prefixed query like ~prefix should transform to 'prefix', not '"prefix'](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/443)
+* [BACK][OPTIM][Separate ngram extraction from document insertion](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/415)
+* [BACK][FIX][Keep only the roots in searchTableNgrams](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/439)
+* [BACK/FRONT][OPTIM][Dev add option to notify users](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/438) and [[notifications] add possibility to notify user from the backend](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/520)
+* [BACK][FIX][Dev worker fixes](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/447)
+* [BACK][FIX][Dev allow for api error in flow](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/440)
+
+## Version 0.0.7.5.1
+
+* [BACK/FRONT][FIX][[search] small refactoring of the search API](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/441) and [[query] a prefixed query like ~prefix should transform to 'prefix', not '"prefix'](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/443)
+* [BACK][FIX][[CLI] db fix command, to fix hyperdata #630](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/505)
+* [BACK][OPTIM][Add the ability to emit logging messages from a `DbTx` transaction](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/436)
+* [BACK][OPTIM][Prevent importing ngrams which will lead to loops](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/435)
+* [FRONT][FIX][[graph] fix updateGraph function so that labels are rendered properly](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/521)
+
 ## Version 0.0.7.5
 
 * [BACK][UPGRADE][Allow ngrams to be searched even if they appear deeply nested](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/433)

README.md

@@ -573,3 +573,13 @@ or `inproc` (this limits us to inter-process communication).
 
 The `bind` part is for the server, the `connect` part is for the
 clients connecting to that server.
+
+## Notifying users and debugging notifications
+
+Since notifications are handled by nng, one can use `nngcat` to send
+handcrafted messages for debugging purposes.
+
+In particular, it is possible to notify individual users like this:
+```shell
+nngcat --push --connect tcp://127.0.0.1:5560 --data '{"user_id": 2, "message": "hello user1","type":"notify_user"}'
+```

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/Ini.hs

@@ -79,9 +79,7 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
                                                        , _f_searx_url = _gc_frame_searx_url
                                                        , _f_istex_url = _gc_frame_istex_url }
                     , _gc_jobs = CTypes.JobsConfig { _jc_max_docs_parsers = _gc_max_docs_parsers
-                                                   , _jc_max_docs_scrapers = _gc_max_docs_scrapers
-                                                   , _jc_js_job_timeout = _gc_js_job_timeout
-                                                   , _jc_js_id_timeout = _gc_js_id_timeout }
+                                                   , _jc_max_docs_scrapers = _gc_max_docs_scrapers }
                     , _gc_apis = CTypes.APIsConfig { _ac_epo_api_url = _gc_epo_api_url
                                                    , _ac_scrapyd_url }
                     , _gc_worker = WorkerSettings { _wsDefinitions = [ wd ]
@@ -89,6 +87,7 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
                                                   , _wsDefaultJobTimeout = 60
                                                   , _wsLongJobTimeout = 3000
                                                   , _wsDefaultDelay = 0
+                                                  , _wsAdditionalDelayAfterRead = 5
                                                   , _wsDatabase = connInfo { PGS.connectDatabase = "pgmq"} }
                     , _gc_logging = Config.LogConfig {
                         _lc_log_level = INFO

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."))

bin/update-project-dependencies

@@ -16,8 +16,8 @@ fi
 # with the `sha256sum` result calculated on the `cabal.project` and
 # `cabal.project.freeze`. This ensures the files stay deterministic so that CI
 # cache can kick in.
-expected_cabal_project_hash="eb8fdb1a14aa2f7a13f565cf7fa9f6ab0e2dab9212538aed0db5691015be286b"
-expected_cabal_project_freeze_hash="a5eb1d9a331266fef56f490712decbd3eaff1fd0daa8bc63f893238a7f47df93"
+expected_cabal_project_hash="a937358694443ac19fd1e16627f071eda308b8b7bbaa5391e657b2f4c6570a5b"
+expected_cabal_project_freeze_hash="91775b174f065d00f22b8265d89d6c0b501e8fb7b0fd8d1b4b2f72ee5578a9f7"
 
 
 cabal --store-dir=$STORE_DIR v2-build --dry-run

cabal.project

@@ -156,7 +156,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/haskell-bee
-    tag: 05c39e424d15149dc32097b3318cb6007e0e7052
+    tag: c00a600b646e10a41ef71befd98dcc578e83fd8b
     subdir: haskell-bee/
             haskell-bee-pgmq/
             haskell-bee-tests/

cabal.project.freeze

@@ -222,7 +222,7 @@ constraints: any.Boolean ==0.2.4,
              hashable +integer-gmp -random-initial-seed,
              any.hashtables ==1.4.2,
              hashtables -bounds-checking -debug -detailed-profiling -portable -sse42 +unsafe-tricks,
-             any.haskell-bee ==0.1.0.0,
+             any.haskell-bee ==0.1.2.0,
              any.haskell-bee-pgmq ==0.1.0.0,
              any.haskell-bee-tests ==0.1.0.0,
              any.haskell-igraph ==0.10.4.1,

gargantext-settings.toml_toModify

@@ -89,10 +89,6 @@ istex_url  = URL_TO_CHANGE
 max_docs_parsers = 4000
 max_docs_scrapers = 4000
 
-# in seconds
-js_job_timeout = 6000
-js_id_timeout = 6000
-
 
 [database]
 # PostgreSQL access
@@ -162,6 +158,9 @@ default_visibility_timeout = 1
 # default delay before job is visible to the worker
 default_delay = 0
 
+# delay after reading the job, should prevent overlaps for multiple workers
+additional_delay_after_read = 15
+
 # default timeout (in seconds)
 default_job_timeout = 60
 # default timeout for "long" jobs (in seconds)

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.7.5
+version: 0.0.7.5.2
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data

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/Admin/Settings.hs

@@ -153,9 +153,6 @@ newEnv logger config dispatcher = do
   let !nodeStory_env = mkNodeStoryEnv
 
   -- secret        <- Jobs.genSecret
-  -- let jobs_settings = (Jobs.defaultJobSettings 1 secret)
-  --                       & Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_jobs . jc_js_job_timeout)
-  --                       & Jobs.l_jsIDTimeout  .~ (fromIntegral $ config_env ^. hasConfig ^. gc_jobs . jc_js_id_timeout)
 
   !_env_jwt_settings <- jwtSettings (_gc_secrets config)
 

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/Errors.hs

@@ -36,6 +36,7 @@ import Gargantext.Database.Query.Tree hiding (treeError)
 import Gargantext.Utils.Jobs.Monad (JobError(..))
 import Network.HTTP.Types.Status qualified as HTTP
 import Servant.Server (ServerError(..), err404, err500)
+import Gargantext.Core.NodeStory (NodeStoryError(..), renderLoop, BuildForestError (..))
 
 $(deriveHttpStatusCode ''BackendErrorCode)
 
@@ -91,6 +92,12 @@ backendErrorToFrontendError = \case
          AccessPolicyErrorReason reason
            -> mkFrontendErr' "A policy check failed"
                 $ FE_policy_check_error reason
+  InternalNodeStoryError nodeStoryError
+    -> case nodeStoryError of
+         NodeStoryUpsertFailed (BFE_loop_detected visited)
+           -- FIXME(adn) proper constructor.
+           -> let msg = "A loop was detected in ngrams: " <> renderLoop visited
+              in mkFrontendErr' msg $ FE_internal_server_error msg
 
 frontendErrorToGQLServerError :: FrontendError -> ServerError
 frontendErrorToGQLServerError fe@(FrontendError diag ty _) =

src/Gargantext/API/Errors/Types.hs

@@ -25,7 +25,7 @@ Portability : POSIX
 module Gargantext.API.Errors.Types (
     HasServerError(..)
   , serverError
-  
+
   -- * The main frontend error type
   , FrontendError(..)
 
@@ -48,9 +48,10 @@ module Gargantext.API.Errors.Types (
   ) where
 
 import Control.Lens ((#), makePrisms, Prism')
+import Control.Lens.Prism (prism')
 import Control.Monad.Fail (fail)
-import Data.Aeson.Types (typeMismatch, emptyArray)
 import Data.Aeson (Value(..), (.:), (.=), object, withObject)
+import Data.Aeson.Types (typeMismatch, emptyArray)
 import Data.List.NonEmpty qualified as NE
 import Data.Singletons.TH ( SingI(sing), SingKind(fromSing) )
 import Data.Text qualified as T
@@ -59,6 +60,7 @@ import Gargantext.API.Admin.Auth.Types (AuthenticationError)
 import Gargantext.API.Errors.Class (HasAuthenticationError(..))
 import Gargantext.API.Errors.TH ( deriveIsFrontendErrorData )
 import Gargantext.API.Errors.Types.Backend
+import Gargantext.Core.NodeStory.Types
 import Gargantext.Core.Types (HasValidationError(..))
 import Gargantext.Core.Types.Individu (Username)
 import Gargantext.Database.Admin.Types.Node
@@ -68,7 +70,6 @@ import Gargantext.Prelude hiding (Location, WithStacktrace)
 import Gargantext.Utils.Dict (Dict(..))
 import Gargantext.Utils.Jobs.Monad qualified as Jobs
 import Servant (ServerError)
-import Control.Lens.Prism (prism')
 
 -- | A 'WithStacktrace' carries an error alongside its
 -- 'CallStack', to be able to print the correct source location
@@ -120,6 +121,7 @@ data BackendInternalError
   | InternalValidationError     !Validation
   | InternalWorkerError         !IOException
   | AccessPolicyError           !AccessPolicyErrorReason
+  | InternalNodeStoryError      !NodeStoryError
   deriving (Show, Typeable)
 
 makePrisms ''BackendInternalError
@@ -142,7 +144,21 @@ instance ToJSON BackendInternalError where
         _ -> ""
   toJSON err = object [("error", String $ T.pack $ show err)]
 
-instance Exception BackendInternalError
+instance Jobs.ToHumanFriendlyError BackendInternalError where
+  mkHumanFriendly e = case e of
+    InternalAuthenticationError{} -> show e
+    InternalJobError{} -> show e
+    InternalNodeError{} -> show e
+    InternalServerError{} -> show e
+    InternalTreeError{} -> show e
+    InternalUnexpectedError{} -> show e
+    InternalValidationError{} -> show e
+    InternalWorkerError{}     -> show e
+    AccessPolicyError{} -> show e
+    InternalNodeStoryError nodeStoryErr -> Jobs.mkHumanFriendly nodeStoryErr
+
+instance Exception BackendInternalError where
+  displayException = T.unpack . Jobs.mkHumanFriendly
 
 instance HasNodeError BackendInternalError where
   _NodeError = _InternalNodeError
@@ -159,6 +175,9 @@ instance HasServerError BackendInternalError where
 instance HasAuthenticationError BackendInternalError where
   _AuthenticationError = _InternalAuthenticationError
 
+instance HasNodeStoryError BackendInternalError where
+  _NodeStoryError = _InternalNodeStoryError
+
 -- | An error that can be returned to the frontend. It carries a human-friendly
 -- diagnostic, the 'type' of the error as well as some context-specific data.
 data FrontendError where

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
@@ -111,6 +112,7 @@ import Data.Tree
 import Gargantext.API.Ngrams.Tools (getNodeStory)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory hiding (buildForest)
+import Gargantext.Core.NodeStory qualified as NodeStory
 import Gargantext.Core.Text.Ngrams (Ngrams, NgramsType)
 import Gargantext.Core.Types (ListType(..), NodeId, ListId, TODO, assertValid, ContextId, HasValidationError)
 import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
@@ -118,6 +120,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
 
 
@@ -218,6 +221,13 @@ addListNgrams listId ngramsType nes = do
 -- | TODO: incr the Version number
 -- && should use patch
 -- UNSAFE
+-- FIXME(adinapoli): This function used to be very dangerous as it didn't
+-- prevent imports from creating loops: if we had a list of imported terms with a tree
+-- referencing an existing node in a forest, we could accidentally create loops. The most
+-- efficient way would be to use the patch API to generate a patch for the input, apply it
+-- to the current state and handle conflicts, discovering loops there. However, given that
+-- it's complex to do that, for the moment we use the Forest API to detect loops, failing
+-- if one is found.
 setListNgrams :: NodeStoryEnv err
               -> NodeId
               -> NgramsType
@@ -230,18 +240,6 @@ setListNgrams env listId ngramsType ns = do
                                               Nothing -> Just ns
                                               Just ns' -> Just $ ns <> ns')
   saveNodeStory env listId a'
-  -- liftBase $ atomically $ do
-  --   nls <- readTVar var
-  --   writeTVar var $
-  --     ( unNodeStory
-  --       . at listId . _Just
-  --       . a_state
-  --       . at ngramsType
-  --       %~ (\mns' -> case mns' of
-  --              Nothing -> Just ns
-  --              Just ns' -> Just $ ns <> ns')
-  --     ) nls
-  -- saveNodeStory
 
 
 newNgramsFromNgramsStatePatch :: NgramsStatePatch' -> [Ngrams]
@@ -439,7 +437,7 @@ matchingNode :: Maybe ListType
              -> (NgramsTerm -> Bool)
              -> Tree NgramsElement
              -> Bool
-matchingNode listType minSize maxSize searchQuery (Node inputNode children) =
+matchingNode listType minSize maxSize searchFn (Node inputNode children) =
   let nodeSize        = inputNode ^. ne_size
       matchesListType = maybe (const True) (==) listType
       respectsMinSize = maybe (const True) ((<=) . getMinSize) minSize
@@ -448,66 +446,13 @@ matchingNode listType minSize maxSize searchQuery (Node inputNode children) =
   in    respectsMinSize nodeSize
      && respectsMaxSize nodeSize
      -- Search for the query either in the root or in the children.
-     && (searchQuery (inputNode ^. ne_ngrams) || any (matchingNode listType minSize maxSize searchQuery) children)
+     && (searchFn (inputNode ^. ne_ngrams) || any (matchingNode listType minSize maxSize searchFn) children)
      && matchesListType (inputNode ^. ne_list)
 
--- | Errors returned by 'buildForest'.
-data BuildForestError
-  = -- We found a loop, something that shouldn't normally happen if the calling
-    -- code is correct by construction, but if that does happen, the value will
-    -- contain the full path to the cycle.
-    BFE_loop_detected !(Set VisitedNode)
-  deriving (Show, Eq)
-
-renderLoop :: Set VisitedNode -> T.Text
-renderLoop = T.intercalate " -> " . map (unNgramsTerm . _vn_term) . Set.toAscList
-
--- | Keeps track of the relative order in which visited a node, to be able to print cycles.
-data VisitedNode =
-  VN { _vn_position :: !Int, _vn_term :: !NgramsTerm }
-  deriving (Show)
-
-instance Eq VisitedNode where
-  (VN _ t1) == (VN _ t2) = t1 == t2
-
-instance Ord VisitedNode where
-  compare (VN _ t1) (VN _ t2) = t1 `compare` t2
-
-type TreeNode = (NgramsTerm, NgramsElement)
-
 -- | Version of 'buildForest' specialised over the 'NgramsElement' as the values of the tree.
--- We can't use a single function to \"rule them all\" because the 'NgramsRepoElement', that
--- the 'NodeStory' uses does not have an 'ngrams' we can use as the key when building and
--- destroying a forest.
 -- /IMPORTANT/: This functions returns an error in case we found a loop.
 buildForest :: Map NgramsTerm NgramsElement -> Either BuildForestError (Forest NgramsElement)
-buildForest mp = fmap (map (fmap snd)) . unfoldForestM unfoldNode $ Map.toList mp
-  where
-    unfoldNode :: TreeNode -> Either BuildForestError (TreeNode, [TreeNode])
-    unfoldNode (n, el) = flip evalState (1 :: Int, mempty) . runExceptT $ do
-      let initialChildren = getChildren (mSetToList $ _ne_children el)
-      go initialChildren *> pure (mkTreeNode (n, el))
-      where
-        go :: [ NgramsElement ]
-           -> ExceptT BuildForestError (State (Int, Set VisitedNode)) ()
-        go []     = pure ()
-        go (x:xs) = do
-          (pos, visited) <- get
-          let nt = _ne_ngrams x
-          case Set.member (VN pos nt) visited of
-            True  -> throwError $ BFE_loop_detected visited
-            False -> do
-              put (pos + 1, Set.insert (VN (pos + 1) nt) visited)
-              go (getChildren (mSetToList $ _ne_children x) <> xs)
-
-    mkTreeNode :: TreeNode -> (TreeNode, [TreeNode])
-    mkTreeNode (k, el) = ((k, el), mapMaybe findChildren $ mSetToList (el ^. ne_children))
-
-    findChildren :: NgramsTerm -> Maybe TreeNode
-    findChildren t = Map.lookup t mp <&> \el -> (t, el)
-
-    getChildren :: [NgramsTerm] -> [NgramsElement]
-    getChildren = mapMaybe (`Map.lookup` mp)
+buildForest = fmap (map (fmap snd)) . NodeStory.buildForest
 
 -- | Folds an Ngrams forest back to a table map.
 -- This function doesn't aggregate information, but merely just recostructs the original
@@ -627,6 +572,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
@@ -637,21 +583,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/FrameCalcUpload.hs

@@ -23,7 +23,7 @@ import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Node.Corpus.New (addToCorpusWithTempFile)
 import Gargantext.API.Node.Corpus.New.Types (FileFormat(..), FileType(..))
-import Gargantext.API.Node.FrameCalcUpload.Types
+import Gargantext.API.Node.FrameCalcUpload.Types ( FrameCalcUpload(FrameCalcUpload) )
 import Gargantext.API.Node.Types (NewWithTempFile(..))
 import Gargantext.API.Prelude ( GargM )
 import Gargantext.API.Routes.Named.FrameCalc qualified as Named

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/Types.hs

@@ -41,8 +41,6 @@ module Gargantext.Core.Config.Types
   , JobsConfig(..)
   , jc_max_docs_parsers
   , jc_max_docs_scrapers
-  , jc_js_job_timeout
-  , jc_js_id_timeout
   , MicroServicesSettings(..)
   , NotificationsConfig(..)
   , JWKFile(..)
@@ -290,24 +288,19 @@ jwtSettings (SecretsConfig { _s_jwk_file = JWKFile jwkFile }) = do
 
 data JobsConfig =
   JobsConfig { _jc_max_docs_parsers  :: !Integer
-             , _jc_max_docs_scrapers :: !Integer
-             , _jc_js_job_timeout    :: !Integer
-             , _jc_js_id_timeout     :: !Integer }
+             , _jc_max_docs_scrapers :: !Integer }
   deriving (Generic, Show)
 instance FromValue JobsConfig where
   fromValue = parseTableFromValue $ do
     _jc_max_docs_parsers <- reqKey "max_docs_parsers"
     _jc_max_docs_scrapers <- reqKey "max_docs_scrapers"
-    _jc_js_job_timeout <- reqKey "js_job_timeout"
-    _jc_js_id_timeout <- reqKey "js_id_timeout"
     return $ JobsConfig { .. }
 instance ToValue JobsConfig where
   toValue = defaultTableToValue
 instance ToTable JobsConfig where
-  toTable (JobsConfig { .. }) = table [ "max_docs_parsers" .= _jc_max_docs_parsers
-                                      , "max_docs_scrapers" .= _jc_max_docs_scrapers
-                                      , "js_job_timeout" .= _jc_js_job_timeout
-                                      , "js_id_timeout" .= _jc_js_id_timeout ]
+  toTable (JobsConfig { .. }) =
+    table [ "max_docs_parsers" .= _jc_max_docs_parsers
+          , "max_docs_scrapers" .= _jc_max_docs_scrapers ]
 
 makeLenses ''JobsConfig
 

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

@@ -51,6 +51,7 @@ data WorkerSettings =
     -- Default delay for jobs. This is useful in tests, so that we can
     -- get a chance to set up proper watchers for job, given its id
     , _wsDefaultDelay :: B.TimeoutS
+    , _wsAdditionalDelayAfterRead :: B.TimeoutS
     , _wsDefinitions  :: ![WorkerDefinition]
   } deriving (Show, Eq)
 instance FromValue WorkerSettings where
@@ -61,12 +62,14 @@ instance FromValue WorkerSettings where
     _wsDefaultJobTimeout <- reqKey "default_job_timeout"
     _wsLongJobTimeout <- reqKey "long_job_timeout"
     defaultDelay <- reqKey "default_delay"
+    additionalDelayAfterRead <- reqKey "additional_delay_after_read"
     return $ WorkerSettings { _wsDatabase = unTOMLConnectInfo dbConfig
                             , _wsDefaultJobTimeout
                             , _wsLongJobTimeout
                             , _wsDefinitions
                             , _wsDefaultVisibilityTimeout
-                            , _wsDefaultDelay = B.TimeoutS defaultDelay }
+                            , _wsDefaultDelay = B.TimeoutS defaultDelay
+                            , _wsAdditionalDelayAfterRead = B.TimeoutS additionalDelayAfterRead }
 instance ToValue WorkerSettings where
   toValue = defaultTableToValue
 instance ToTable WorkerSettings where
@@ -76,6 +79,7 @@ instance ToTable WorkerSettings where
           , "long_job_timeout" .= _wsLongJobTimeout
           , "default_visibility_timeout" .= _wsDefaultVisibilityTimeout
           , "default_delay" .= B._TimeoutS _wsDefaultDelay
+          , "additional_delay_after_read" .= B._TimeoutS _wsAdditionalDelayAfterRead
           , "definitions" .= _wsDefinitions ]
 
 data WorkerDefinition =

src/Gargantext/Core/NodeStory.hs

@@ -40,10 +40,10 @@ TODO:
 - charger les listes
 -}
 
-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE ConstraintKinds   #-}
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
 
 module Gargantext.Core.NodeStory
   ( module Gargantext.Core.NodeStory.Types
@@ -62,14 +62,18 @@ module Gargantext.Core.NodeStory
   , fixNodeStoryVersions
   , getParentsChildren
   -- * Operations on trees and forests
+  , TreeNode
+  , BuildForestError(..)
+  , VisitedNode(..)
   , buildForest
   , pruneForest
   ) where
 
-import Control.Lens ((%~), non, _Just, at, over, Lens')
+import Control.Lens ((%~), non, _Just, at, over, Lens', (#))
 import Data.ListZipper
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
+import Data.Tree
 import Database.PostgreSQL.Simple qualified as PGS
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.ToField qualified as PGS
@@ -77,11 +81,10 @@ import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory.DB
 import Gargantext.Core.NodeStory.Types
 import Gargantext.Core.Text.Ngrams qualified as Ngrams
-import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
 import Gargantext.Database.Admin.Config ()
+import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
 import Gargantext.Database.Prelude
 import Gargantext.Prelude hiding (to)
-import Data.Tree
 
 class HasNgramChildren e where
   ngramsElementChildren :: Lens' e (MSet NgramsTerm)
@@ -109,35 +112,60 @@ instance HasNgramParent NgramsElement where
 -- piece of a data structure.
 type ArchiveStateForest = ListZipper (Tree (NgramsTerm, NgramsRepoElement))
 
-buildForestsFromArchiveState :: NgramsState' -> Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
-buildForestsFromArchiveState = Map.map buildForest
+type TreeNode e = (NgramsTerm, e)
+
+buildForestsFromArchiveState :: NgramsState'
+                             -> Either BuildForestError (Map Ngrams.NgramsType (Forest (TreeNode NgramsRepoElement)))
+buildForestsFromArchiveState = traverse buildForest
 
-destroyArchiveStateForest :: Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement)) -> NgramsState'
+destroyArchiveStateForest :: Map Ngrams.NgramsType (Forest (TreeNode NgramsRepoElement)) -> NgramsState'
 destroyArchiveStateForest = Map.map destroyForest
 
 -- | Builds an ngrams forest from the input ngrams table map.
-buildForest :: forall e. HasNgramChildren e => Map NgramsTerm e -> Forest (NgramsTerm, e)
-buildForest mp = unfoldForest mkTreeNode (Map.toList mp)
+buildForest :: forall e. HasNgramChildren e => Map NgramsTerm e -> Either BuildForestError (Forest (TreeNode e))
+buildForest mp = unfoldForestM unfoldNode $ Map.toList mp
   where
-    mkTreeNode :: (NgramsTerm, e) -> ((NgramsTerm, e), [(NgramsTerm, e)])
+    unfoldNode :: TreeNode e -> Either BuildForestError (TreeNode e, [TreeNode e])
+    unfoldNode (n, el) = flip evalState (1 :: Int, mempty) . runExceptT $ do
+      let initialChildren = getChildren (mSetToList $ el ^. ngramsElementChildren)
+      go initialChildren *> pure (mkTreeNode (n, el))
+      where
+        -- This function is quite simple: the internal 'State' keeps track of the current
+        -- position of the visit, and if we discover a term we already seen before, we throw
+        -- an error, otherwise we store it in the state at the current position and carry on.
+        go :: [ TreeNode e ] -> ExceptT BuildForestError (State (Int, Set VisitedNode)) ()
+        go []     = pure ()
+        go (x:xs) = do
+          (!pos, !visited) <- get
+          let nt = fst x
+          case Set.member (VN pos nt) visited of
+            True  -> throwError $ BFE_loop_detected visited
+            False -> do
+              put (pos + 1, Set.insert (VN (pos + 1) nt) visited)
+              go (getChildren (mSetToList $ snd x ^. ngramsElementChildren) <> xs)
+
+    mkTreeNode :: TreeNode e -> (TreeNode e, [TreeNode e])
     mkTreeNode (k, el) = ((k, el), mapMaybe findChildren $ mSetToList (el ^. ngramsElementChildren))
 
-    findChildren :: NgramsTerm -> Maybe (NgramsTerm, e)
+    findChildren :: NgramsTerm -> Maybe (TreeNode e)
     findChildren t = Map.lookup t mp <&> \el -> (t, el)
 
+    getChildren :: [NgramsTerm] -> [TreeNode e]
+    getChildren = mapMaybe (\t -> (t,) <$> Map.lookup t mp)
+
 -- | Folds an Ngrams forest back to a table map.
 -- This function doesn't aggregate information, but merely just recostructs the original
 -- map without loss of information. To perform operations on the forest, use the appropriate
 -- functions.
-destroyForest :: Forest (NgramsTerm, NgramsRepoElement) -> Map NgramsTerm NgramsRepoElement
+destroyForest :: Forest (TreeNode NgramsRepoElement) -> Map NgramsTerm NgramsRepoElement
 destroyForest f = Map.fromList . map (foldTree destroyTree) $ f
   where
-    destroyTree :: (NgramsTerm, NgramsRepoElement)
-                -> [(NgramsTerm, NgramsRepoElement)]
-                -> (NgramsTerm, NgramsRepoElement)
+    destroyTree :: TreeNode NgramsRepoElement
+                -> [TreeNode NgramsRepoElement]
+                -> TreeNode NgramsRepoElement
     destroyTree (k, rootEl) childrenEl = (k, squashElements rootEl childrenEl)
 
-    squashElements :: e -> [(NgramsTerm, e)] -> e
+    squashElements :: e -> [TreeNode e] -> e
     squashElements r _ = r
 
 -- | Prunes the input 'Forest' of 'NgramsElement' by keeping only the roots, i.e. the
@@ -357,17 +385,14 @@ getParentsChildren ns = (nsParents, nsChildren)
 
 ------------------------------------
 
-mkNodeStoryEnv :: NodeStoryEnv err
+mkNodeStoryEnv :: HasNodeStoryError err => NodeStoryEnv err
 mkNodeStoryEnv = do
   let saver_immediate nId a = do
         -- |NOTE Fixing a_state is kinda a hack. We shouldn't land
         -- |with bad state in the first place.
-        upsertNodeStories nId $
-          a & a_state %~ (
-                    destroyArchiveStateForest
-                  . fixChildrenWithNoParent
-                  . buildForestsFromArchiveState
-                  )
+        forests <- dbCheckOrFail (first (\e -> _NodeStoryError # NodeStoryUpsertFailed e) $ buildForestsFromArchiveState $ a ^. a_state)
+        upsertNodeStories nId $ do
+          a & a_state .~ (destroyArchiveStateForest . fixChildrenWithNoParent $ forests)
   let archive_saver_immediate nId a = do
         insertNodeArchiveHistory nId (a ^. a_version) $ reverse $ a ^. a_history
         pure $ a & a_history .~ []

src/Gargantext/Core/NodeStory/Types.hs

@@ -8,10 +8,9 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-{-# LANGUAGE Arrows #-}
 {-# LANGUAGE ConstraintKinds   #-}
-{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE ViewPatterns      #-}
 
 module Gargantext.Core.NodeStory.Types
   ( HasNodeStory
@@ -42,25 +41,35 @@ module Gargantext.Core.NodeStory.Types
   , combineState
   , ArchiveState
   , ArchiveStateSet
-  , ArchiveStateList )
+  , ArchiveStateList
+
+  -- * Errors
+  , HasNodeStoryError(..)
+  , NodeStoryError(..)
+  , BuildForestError(..)
+  , VisitedNode(..)
+  , renderLoop
+  )
 where
 
 import Codec.Serialise.Class ( Serialise )
-import Control.Lens (Getter, Lens')
+import Control.Lens (Getter, Lens', Prism', prism')
 import Data.Aeson hiding ((.=), decode)
 import Data.Map.Strict qualified as Map
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Data.Set qualified as Set
 import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
 import Gargantext.API.Ngrams.Types
-import Gargantext.Database.Admin.Types.Node ( NodeId(..) )
 import Gargantext.Core.Text.Ngrams qualified as Ngrams
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Admin.Config ()
+import Gargantext.Database.Admin.Types.Node ( NodeId(..) )
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
 import Gargantext.Prelude hiding (to)
+import Gargantext.Utils.Jobs.Error
 import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
+import qualified Data.Text as T
 
 
 ------------------------------------------------------------------------
@@ -183,7 +192,47 @@ $(makeAdaptorAndInstance "pNodeArchiveStory" ''NodeStoryArchivePoly)
 
 type ArchiveList = Archive NgramsState' NgramsStatePatch'
 
-
+-- | Errors returned by 'buildForest'.
+data BuildForestError
+  = -- We found a loop, something that shouldn't normally happen if the calling
+    -- code is correct by construction, but if that does happen, the value will
+    -- contain the full path to the cycle.
+    BFE_loop_detected !(Set VisitedNode)
+  deriving (Show, Eq)
+
+instance ToHumanFriendlyError BuildForestError where
+  mkHumanFriendly (BFE_loop_detected visited)
+    = "Loop detected in terms: " <> renderLoop visited
+
+renderLoop :: Set VisitedNode -> T.Text
+renderLoop (sortBy (comparing _vn_position) . Set.toList -> visited) = case visited of
+  [] -> mempty
+  (x : _) ->
+    let cycleWithoutRecursiveKnot = T.intercalate " -> " . map (unNgramsTerm . _vn_term) $ visited
+    -- Pretty print the first visited node last, so that the user can "see" the full recursive knot.
+    in cycleWithoutRecursiveKnot <> " -> " <> (unNgramsTerm . _vn_term $ x)
+
+-- | Keeps track of the relative order in which visited a node, to be able to print cycles.
+data VisitedNode =
+  VN { _vn_position :: !Int, _vn_term :: !NgramsTerm }
+  deriving (Show)
+
+-- /NOTA BENE/: It's important to use this custom instance for the loop detector
+-- to work correctly. If we stop comparing on the terms the loop detector .. will loop.
+instance Eq VisitedNode where
+  (VN _ t1) == (VN _ t2) = t1 == t2
+
+-- /NOTA BENE/: Same proviso as for the 'Eq' instance.
+instance Ord VisitedNode where
+  compare (VN _ t1) (VN _ t2) = t1 `compare` t2
+
+data NodeStoryError =
+  NodeStoryUpsertFailed BuildForestError
+  deriving (Show, Eq)
+
+instance ToHumanFriendlyError NodeStoryError where
+  mkHumanFriendly e = case e of
+    NodeStoryUpsertFailed be -> mkHumanFriendly be
 
 ------------------------------------------------------------------------
 data NodeStoryEnv err = NodeStoryEnv
@@ -195,6 +244,12 @@ data NodeStoryEnv err = NodeStoryEnv
   -- , _nse_lock  :: !FileLock -- TODO (it depends on the option: if with database or file only)
   }
 
+class HasNodeStoryError e where
+  _NodeStoryError :: Prism' e NodeStoryError
+
+instance HasNodeStoryError NodeStoryError where
+  _NodeStoryError = prism' identity Just
+
 type HasNodeStory env err m = ( IsDBCmd env err m, HasNodeStoryEnv env err, HasNodeError err)
 
 class HasNodeStoryEnv env err where

src/Gargantext/Core/Notifications/CentralExchange.hs

@@ -103,6 +103,8 @@ gServer cfg = do
             Just (UpdateWorkerProgress _ji _jl) -> do
               -- $(logLoc) ioLogger DEBUG $ "[central_exchange] update worker progress: " <> show ji <> ", " <> show jl
               sendTimeout nc ioLogger s_dispatcher r
+            Just (NotifyUser _uid _msg) -> do
+              sendTimeout nc ioLogger s_dispatcher r
             Just Ping -> do
               sendTimeout nc ioLogger s_dispatcher r
             Nothing ->

src/Gargantext/Core/Notifications/CentralExchange/Types.hs

@@ -20,6 +20,7 @@ import Data.Aeson.Types (prependFailure, typeMismatch)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog)
 import Gargantext.Core.Types (NodeId)
 import Gargantext.Core.Worker.Types (JobInfo)
+import Gargantext.Database.Admin.Types.Node (UserId)
 import Gargantext.Prelude
 import Prelude qualified
     
@@ -40,11 +41,13 @@ data CEMessage =
     UpdateWorkerProgress JobInfo JobLog
     -- | Update tree for given nodeId
   | UpdateTreeFirstLevel NodeId
+  | NotifyUser UserId Text
   | Ping
 instance Prelude.Show CEMessage where
   -- show (UpdateWorkerProgress ji nodeId jl) = "UpdateWorkerProgress " <> show ji <> " " <> show nodeId <> " " <> show jl
   show (UpdateWorkerProgress ji jl) = "UpdateWorkerProgress " <> show ji <> " " <> show jl
   show (UpdateTreeFirstLevel nodeId) = "UpdateTreeFirstLevel " <> show nodeId
+  show (NotifyUser userId msg) = "NotifyUser " <> show userId <> ", " <> show msg
   show Ping = "Ping"
 instance FromJSON CEMessage where
   parseJSON = withObject "CEMessage" $ \o -> do
@@ -59,6 +62,10 @@ instance FromJSON CEMessage where
       "update_tree_first_level" -> do
         node_id <- o .: "node_id"
         pure $ UpdateTreeFirstLevel node_id
+      "notify_user" -> do
+        user_id <- o .: "user_id"
+        msg <- o .: "message"
+        pure $ NotifyUser user_id msg
       "ping" -> pure Ping
       s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
 instance ToJSON CEMessage where
@@ -72,8 +79,14 @@ instance ToJSON CEMessage where
       "type"    .= ("update_tree_first_level" :: Text)
     , "node_id" .= nodeId
     ]
+  toJSON (NotifyUser userId msg) = object [
+      "type"    .= ("notify_user" :: Text)
+    , "user_id" .= userId
+    , "message" .= msg
+    ]
   toJSON Ping = object [ "type" .= ("ping" :: Text) ]
 
 
 class HasCentralExchangeNotification env where
   ce_notify :: (MonadReader env m, MonadBase IO m) => CEMessage -> m ()
+

src/Gargantext/Core/Notifications/Dispatcher.hs

@@ -29,6 +29,7 @@ import Control.Concurrent.STM.TChan qualified as TChan
 import Control.Concurrent.Throttle (throttle)
 import Data.Aeson qualified as Aeson
 import Data.ByteString.Lazy qualified as BSL
+import Data.List (nubBy)
 import Data.Text qualified as T
 import DeferredFolds.UnfoldlM qualified as UnfoldlM
 import Gargantext.Core.Config
@@ -107,7 +108,17 @@ dispatcherListener config subscriptions = do
 
         case Aeson.decode (BSL.fromStrict r) of
           Nothing ->
-              logMsg ioL DEBUG "[dispatcher_listener] unknown message from central exchange"
+            logMsg ioL DEBUG "[dispatcher_listener] unknown message from central exchange"
+          -- Just n@(CETypes.NotifyUser _userId _msg) -> do
+          --   -- A single user could have multiple subcriptions. We only
+          --   -- want to send one notification to each of this user's
+          --   -- browsers. That's why we have the 'WSKeyConnection' type
+          --   logMsg ioL DEBUG $ "[dispatcher_listener] received " <> show n
+          --   -- subs <- atomically $ readTVar subscriptions
+          --   filteredSubs <- atomically $ do
+          --     let subs' = UnfoldlM.filter (pure . ceMessageSubPred n) $ SSet.unfoldlM subscriptions
+          --     UnfoldlM.foldlM' (\acc sub -> pure $ acc <> [sub]) [] subs'
+          --   pure ()
           Just ceMessage -> do
             logMsg ioL DEBUG $ "[dispatcher_listener] received " <> show ceMessage
             -- subs <- atomically $ readTVar subscriptions
@@ -122,7 +133,13 @@ dispatcherListener config subscriptions = do
             -- one drops in the meantime, it won't listen to what we
             -- send...)
             -- let filteredSubs = filterCEMessageSubs ceMessage subs
-            mapM_ (sendNotification throttleTChan ceMessage) filteredSubs
+            
+            -- We do 'nubBy' because we want to send only 1 such
+            -- message to each connection, even if there are more
+            -- subscriptions from the same user (multiple subcriptions
+            -- could have matched the above 'ceMessageSubPred').
+            let uniqueConnections = nubBy (\a b -> s_ws_key_connection a == s_ws_key_connection b) filteredSubs
+            mapM_ (sendNotification throttleTChan ceMessage) uniqueConnections
 
 -- | When processing tasks such as Flow, we can generate quite a few
 -- notifications in a short time. We want to limit this with throttle
@@ -157,6 +174,8 @@ sendNotification throttleTChan ceMessage sub = do
             else Nothing
           (Ping, CETypes.Ping) ->
             Just NPing
+          (_, CETypes.NotifyUser userId msg) ->
+            Just $ NNotifyUser userId msg
           _ -> Nothing
 
   case mNotification of
@@ -200,5 +219,7 @@ ceMessageSubPred (CETypes.UpdateWorkerProgress ji _jl) (Subscription { s_topic }
   || Just s_topic == (UpdateTree <$> _ji_mNode_id ji)
 ceMessageSubPred (CETypes.UpdateTreeFirstLevel nodeId) (Subscription { s_topic }) =
   s_topic == UpdateTree nodeId
+ceMessageSubPred (CETypes.NotifyUser userId _msg) (Subscription { s_connected_user }) =
+  s_connected_user == CUUser userId
 ceMessageSubPred CETypes.Ping (Subscription { s_topic }) =
   s_topic == Ping

src/Gargantext/Core/Notifications/Dispatcher/Types.hs

@@ -211,6 +211,7 @@ data Notification =
   | NUpdateTree NodeId
   | NWorkerJobStarted NodeId JobInfo
   | NWorkerJobFinished NodeId JobInfo
+  | NNotifyUser UserId Text
   | NPing
 instance Prelude.Show Notification where
   -- show (NUpdateWorkerProgress jobInfo nodeId mJobLog) = "NUpdateWorkerProgress " <> show jobInfo <> ", " <> show nodeId <> ", " <> show mJobLog
@@ -218,6 +219,7 @@ instance Prelude.Show Notification where
   show (NUpdateTree nodeId) = "NUpdateTree " <> show nodeId
   show (NWorkerJobStarted nodeId ji) = "NWorkerJobStarted " <> show nodeId <> ", " <> show ji
   show (NWorkerJobFinished nodeId ji) = "NWorkerJobFinished " <> show nodeId <> ", " <> show ji
+  show (NNotifyUser userId msg) = "NNotifyUser " <> show userId <> ", " <> show msg
   show NPing = "NPing"
 instance ToJSON Notification where
   -- toJSON (NUpdateWorkerProgress jobInfo nodeId mJobLog) = Aeson.object [
@@ -241,6 +243,11 @@ instance ToJSON Notification where
     , "node_id" .= toJSON nodeId
     , "ji" .= toJSON ji
     ]
+  toJSON (NNotifyUser userId msg) = Aeson.object [
+      "type" .= ("notify_user" :: Text)
+    , "user_id" .= toJSON userId
+    , "message" .= toJSON msg
+    ]
   toJSON NPing = Aeson.object [ "type" .= ("ping" :: Text) ]
 -- We don't need to decode notifications, this is for tests only
 instance FromJSON Notification where
@@ -264,5 +271,9 @@ instance FromJSON Notification where
         nodeId <- o .: "node_id"
         ji <- o .: "ji"
         pure $ NWorkerJobFinished nodeId ji
+      "notify_user" -> do
+        userId <- o .: "user_id"
+        msg <- o .: "message"
+        pure $ NNotifyUser userId msg
       "ping" -> pure NPing
       s -> prependFailure "parsing type failed, " (typeMismatch "type" s)

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/Text/Corpus/Query.hs

@@ -113,12 +113,12 @@ queryTermToken = do
      '"' : '~' : rest
        -> QT_partial_match (Term $ T.pack $ '"' : rest)
      '~' : rest
-       -> QT_partial_match (Term $ T.pack $ '"' : rest)
+       -> QT_partial_match (Term $ T.pack rest)
      _
        -> QT_exact_match (Term $ T.pack t)
 
 termToken :: CharParser st [Term]
-termToken = (try ((:[]) . Term . T.pack <$> BoolExpr.identifier) <|> (between dubQuote dubQuote multipleTerms))
+termToken = try ((:[]) . Term . T.pack <$> BoolExpr.identifier) <|> (between dubQuote dubQuote multipleTerms)
   where
     dubQuote      = BoolExpr.symbol "\""
     multipleTerms = map (Term . T.pack) <$> sepBy BoolExpr.identifier BoolExpr.whiteSpace

src/Gargantext/Core/Text/Ngrams.hs

@@ -40,6 +40,7 @@ import Text.Read (read)
 data NgramsType = Authors | Institutes | Sources | NgramsTerms
   deriving (Eq, Show, Read, Ord, Enum, Bounded, Generic)
 
+instance NFData NgramsType
 instance Serialise NgramsType
 instance FromJSON NgramsType
   where

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

@@ -86,11 +86,11 @@ notifyJobStarted :: HasWorkerBroker
                  -> BrokerMessage
                  -> IO ()
 notifyJobStarted env (W.State { name }) bm = do
-  let mId = messageId bm
+  let msgId = messageId bm
   let j = toA $ getMessage bm
   let job = W.job j
   withLogger (env ^. w_env_config . gc_logging) $ \ioL ->
-    $(logLoc) ioL DEBUG $ T.pack $ "[notifyJobStarted] [" <> name <> " :: " <> show mId <> "] starting job: " <> show j
+    $(logLoc) ioL DEBUG $ T.pack $ "[notifyJobStarted] [" <> name <> " :: " <> show msgId <> "] starting job: " <> show j
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
   let jh = WorkerJobHandle { _w_job_info = ji }
@@ -143,7 +143,7 @@ notifyJobFailed env (W.State { name }) bm exc = do
   let ji = JobInfo { _ji_message_id = messageId bm
                    , _ji_mNode_id = getWorkerMNodeId job }
   let jh = WorkerJobHandle { _w_job_info = ji }
-  runWorkerMonad env $ markFailed (Just $ UnsafeMkHumanFriendlyErrorText $ "Worker job failed: " <> show exc) jh
+  runWorkerMonad env $ markFailed (Just $ UnsafeMkHumanFriendlyErrorText $ T.pack $ displayException exc) jh
 
 notifyJobKilled :: (HasWorkerBroker, HasCallStack)
                  => WorkerEnv
@@ -213,7 +213,7 @@ performAction :: HasWorkerBroker
               -> WState
               -> BrokerMessage
               -> IO ()
-performAction env _state bm = do
+performAction env _s bm = do
   let job' = toA $ getMessage bm
   let job = W.job job'
   let ji = JobInfo { _ji_message_id = messageId bm

src/Gargantext/Core/Worker/Jobs.hs

@@ -15,10 +15,11 @@ module Gargantext.Core.Worker.Jobs where
 
 
 import Async.Worker qualified as W
+import Async.Worker.Broker.Types qualified as B
 import Async.Worker.Types qualified as WT
 import Control.Lens (view)
 import Gargantext.Core.Config (gc_database_config, gc_worker, HasConfig(..), GargConfig, gc_logging)
-import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
+import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..), wsAdditionalDelayAfterRead)
 import Gargantext.Core.Worker.Broker (initBrokerWithDBCreate)
 import Gargantext.Core.Worker.Jobs.Types (Job(..))
 import Gargantext.Core.Worker.PGMQTypes (HasWorkerBroker, MessageId, SendJob)
@@ -45,23 +46,23 @@ sendJobWithCfg gcConfig job = do
     Just wd -> do
       b <- initBrokerWithDBCreate (gcConfig ^. gc_database_config) ws
       let queueName = _wdQueue wd
-      let job' = (updateJobData ws job $ W.mkDefaultSendJob' b queueName job) { W.delay = _wsDefaultDelay }
+      let addDelayAfterRead = gcConfig ^. gc_worker . wsAdditionalDelayAfterRead
+      let job' = (updateJobData ws job $ W.mkDefaultSendJob' b queueName job) { W.delay = _wsDefaultDelay
+                                                                              , W.addDelayAfterRead = B._TimeoutS addDelayAfterRead
+                                                                              , W.toStrat = WT.TSDelete }
       withLogger (gcConfig ^. gc_logging) $ \ioL ->
         $(logLoc) ioL DEBUG $ "[sendJob] sending job " <> show job <> " (delay " <> show (W.delay job') <> ")"
       W.sendJob' job'
 
 -- | We want to fine-tune job metadata parameters, for each job type
 updateJobData :: WorkerSettings -> Job -> SendJob -> SendJob
-updateJobData ws (AddCorpusTempFileAsync {}) sj = withLongTimeout ws $ sj { W.toStrat = WT.TSDelete
-                                                                          , W.resendOnKill = False }
+updateJobData ws (AddCorpusTempFileAsync {}) sj = withLongTimeout ws $ sj { W.resendOnKill = False }
 updateJobData ws (AddCorpusWithQuery {}) sj = withLongTimeout ws sj
 updateJobData ws (AddToAnnuaireWithForm {}) sj = withLongTimeout ws sj
-updateJobData ws (AddWithFile {}) sj = withLongTimeout ws $ sj { W.toStrat = WT.TSDelete
-                                                               , W.resendOnKill = False }
+updateJobData ws (AddWithFile {}) sj = withLongTimeout ws $ sj { W.resendOnKill = False }
 updateJobData ws (DocumentsFromWriteNodes {}) sj = withLongTimeout ws sj
 updateJobData ws (FrameCalcUpload {}) sj = withLongTimeout ws sj
-updateJobData ws (JSONPost {}) sj = withLongTimeout ws $ sj { W.toStrat = WT.TSDelete
-                                                            , W.resendOnKill = False }
+updateJobData ws (JSONPost {}) sj = withLongTimeout ws $ sj { W.resendOnKill = False }
 updateJobData ws (NgramsPostCharts {}) sj = withLongTimeout ws sj
 updateJobData ws (RecomputeGraph {}) sj = withLongTimeout ws sj
 updateJobData ws (UpdateNode {}) sj = withLongTimeout ws sj

src/Gargantext/Database/Action/Flow.hs

@@ -112,7 +112,8 @@ import Gargantext.Database.Schema.Node
 import Gargantext.Database.Types
 import Gargantext.Prelude hiding (catch, onException, to)
 import Gargantext.System.Logging ( logLocM, LogLevel(DEBUG, ERROR), MonadLogger )
-import Gargantext.Utils.Jobs.Monad ( JobHandle, MonadJobStatus(..) )
+import Gargantext.Utils.Jobs.Monad ( JobHandle, MonadJobStatus(..), markFailureNoErr )
+import Servant.Client.Core (ClientError)
 
 ------------------------------------------------------------------------
 -- Imports for upgrade function
@@ -298,10 +299,21 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do
   (_userId, userCorpusId, listId, msgs) <- runDBTx $ createNodes cfg mkCorpusUser c
   forM_ msgs ce_notify
   -- TODO if public insertMasterDocs else insertUserDocs
-  runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC
+  runConduit (zipSources (yieldMany ([1..] :: [Int])) docsC
     .| CList.chunksOf 5
     .| mapM_C (addDocumentsWithProgress userCorpusId)
-    .| sinkNull
+    .| sinkNull) `CES.catches`
+      [ CES.Handler $ \(e :: ClientError) -> do
+                        $(logLocM) ERROR ("Client error: " <> show e :: Text)
+                        markFailure 1 (Just e) jobHandle
+                        -- ignore this and proceed with list generation
+                        pure ()
+      , CES.Handler $ \(e :: SomeException) -> do
+                        $(logLocM) ERROR ("Exception during API call: " <> show e :: Text)
+                        markFailureNoErr 1 jobHandle
+                        -- ignore this and proceed with list generation
+                        pure ()
+      ]
 
   let u = userFromMkCorpusUser mkCorpusUser
     
@@ -341,8 +353,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
 
@@ -427,7 +439,7 @@ buildSocialList l user userCorpusId listId ctype = \case
       (master_user_id, _masterRootId, master_corpus_id)
         <- getOrMkRootWithCorpus cfg MkCorpusUserMaster ctype
 
-      let gp = GroupWithPosTag l nlpServer HashMap.empty
+      let gp = GroupWithPosTag { _gwl_lang = l, _gwl_nlp_config = nlpServer, _gwl_map = mempty }
       (master_user_id, master_corpus_id,) <$> buildNgramsLists user userCorpusId master_corpus_id mfslw gp
 
     -- printDebug "flowCorpusUser:ngs" ngs

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,8 +36,12 @@ module Gargantext.Database.Transactional (
   , mkOpaInsert
   , mkOpaDelete
 
+  -- * Emitting log messages
+  , txLogLocM
+
   -- * Throwing and catching errors (which allows rollbacks)
   , dbFail
+  , dbCheckOrFail
   , catchDBTxError
   , handleDBTxError
   ) where
@@ -49,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)
@@ -127,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
@@ -141,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
@@ -155,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.
@@ -229,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
@@ -335,3 +371,7 @@ mkOpaDelete a = DBTx $ liftF (OpaDelete a id)
 
 dbFail :: err -> DBTx err r b
 dbFail = DBTx . liftF . DBFail
+
+dbCheckOrFail :: Either err a -> DBTx err r a
+dbCheckOrFail (Left e)  = DBTx . liftF . DBFail $ e
+dbCheckOrFail (Right r) = DBTx $ pure r

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

src/Gargantext/Utils/Jobs/Error.hs

@@ -14,9 +14,9 @@ module Gargantext.Utils.Jobs.Error
   , HumanFriendlyErrorText(..)
   ) where
 
-import Prelude
-import Data.Void
-import qualified Data.Text as T
+import Gargantext.Prelude
+import Data.Text qualified as T
+import Servant.Client.Core (ClientError(..))
 
 -- | This class represents the concept of \"human friendly strings\", by which we mean
 -- error messages and/or diagnostics which needs to be displayed to the end users, and, as such:
@@ -43,3 +43,10 @@ instance ToHumanFriendlyError HumanFriendlyErrorText where
 -- /N.B/ Don't get fooled by this instance, it's just to help inference in case we use \"markFailed Nothing\".
 instance ToHumanFriendlyError Void where
   mkHumanFriendly = absurd
+
+instance ToHumanFriendlyError ClientError where
+  mkHumanFriendly (FailureResponse _ _) = "Server returned an error response"
+  mkHumanFriendly (DecodeFailure d _) = "Decode failure: " <> d
+  mkHumanFriendly (UnsupportedContentType mt _) = "Unsupported content type: " <> show mt
+  mkHumanFriendly (InvalidContentTypeHeader _) = "Invalid content type header"
+  mkHumanFriendly (ConnectionError _) = "Connection error"

stack.yaml

@@ -176,15 +176,15 @@
   git: "https://gitlab.iscpif.fr/gargantext/gargantext-graph.git"
   subdirs:
   - "gargantext-graph-core"
-- commit: 05c39e424d15149dc32097b3318cb6007e0e7052
+- commit: c00a600b646e10a41ef71befd98dcc578e83fd8b
   git: "https://gitlab.iscpif.fr/gargantext/haskell-bee"
   subdirs:
   - "haskell-bee-pgmq/"
-- commit: 05c39e424d15149dc32097b3318cb6007e0e7052
+- commit: c00a600b646e10a41ef71befd98dcc578e83fd8b
   git: "https://gitlab.iscpif.fr/gargantext/haskell-bee"
   subdirs:
   - "haskell-bee-tests/"
-- commit: 05c39e424d15149dc32097b3318cb6007e0e7052
+- commit: c00a600b646e10a41ef71befd98dcc578e83fd8b
   git: "https://gitlab.iscpif.fr/gargantext/haskell-bee"
   subdirs:
   - "haskell-bee/"
@@ -369,7 +369,7 @@ flags:
   gargantext:
     "enable-benchmarks": false
     "no-phylo-debug-logs": true
-    "test-crypto": true
+    "test-crypto": false
   graphviz:
     "test-parsing": false
   hashable:

test-data/test_config.toml

@@ -42,8 +42,6 @@ istex_url  = "URL_TO_CHANGE"
 [jobs]
 max_docs_parsers = 1000000
 max_docs_scrapers = 10000
-js_job_timeout = 1800
-js_id_timeout = 1800
 
 # NOTE This is overridden by Test.Database.Setup
 [database]
@@ -93,6 +91,9 @@ default_visibility_timeout = 1
 # default delay before job is visible to the worker
 default_delay = 1
 
+# delay after reading the job, should prevent overlaps for multiple workers
+additional_delay_after_read = 0
+
 # default timeout (in seconds)
 default_job_timeout = 60
 # default timeout for "long" jobs (in seconds)

test/Test/API/Routes.hs

@@ -31,6 +31,7 @@ module Test.API.Routes (
   , get_corpus_sqlite_export
   , addTeamMember
   , importCorpus
+  , get_list_json
   ) where
 
 import Data.Text.Encoding qualified as TE
@@ -39,13 +40,13 @@ import Gargantext.API.Admin.Auth.Types (AuthRequest, AuthResponse, Token)
 import Gargantext.API.Errors
 import Gargantext.API.HashedResponse (HashedResponse)
 import Gargantext.API.Ngrams.List.Types (WithJsonFile, WithTextFile)
-import Gargantext.API.Ngrams.Types ( NgramsTable, NgramsTablePatch, OrderBy, TabType, Versioned, VersionedWithCount )
+import Gargantext.API.Ngrams.Types
 import Gargantext.API.Node.Corpus.Export.Types (CorpusSQLite)
 import Gargantext.API.Node.Share.Types (ShareNodeParams(..))
 import Gargantext.API.Routes.Client
 import Gargantext.API.Routes.Named
 import Gargantext.API.Routes.Named.Corpus (CorpusExportAPI(corpusSQLiteEp))
-import Gargantext.API.Routes.Named.List (updateListJSONEp, updateListTSVEp)
+import Gargantext.API.Routes.Named.List (updateListJSONEp, updateListTSVEp, listJSONEp, getListEp)
 import Gargantext.API.Routes.Named.Node hiding (treeAPI)
 import Gargantext.API.Routes.Named.Private hiding (tableNgramsAPI)
 import Gargantext.API.Routes.Named.Publish (PublishAPI(..), PublishRequest(..))
@@ -401,3 +402,21 @@ importCorpus (toServantToken -> token) corpusId params =
                & ($ corpusId)
                & workerAPIPost
                & (\submitForm -> submitForm params)
+
+get_list_json :: Token
+              -> ListId
+              -> ClientM (Headers '[Header "Content-Disposition" Text] NgramsList)
+get_list_json (toServantToken -> token) lId =
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & listGetAPI
+               & getListEp
+               & ($ lId)
+               & listJSONEp

test/Test/Core/Text/Corpus/Query.hs

 {-# LANGUAGE DerivingStrategies  #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
+
 module Test.Core.Text.Corpus.Query (tests) where
 
 import Data.BoolExpr
-import Data.Conduit
-import Data.String
+import Data.Conduit ( sourceToList )
+import Data.String ( IsString(..) )
+import Data.Text qualified as T
 import Gargantext.Core (Lang(..))
+import Gargantext.Core.Text.Corpus.API.Arxiv qualified as Arxiv
+import Gargantext.Core.Text.Corpus.API.Pubmed qualified as Pubmed
 import Gargantext.Core.Text.Corpus.Query
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
+import Network.Api.Arxiv qualified as Arxiv
 import Prelude
-import System.Environment
-import qualified Data.Text as T
-import qualified Gargantext.Core.Text.Corpus.API.Arxiv as Arxiv
-import qualified Gargantext.Core.Text.Corpus.API.Pubmed as Pubmed
-import qualified Network.Api.Arxiv as Arxiv
+import System.Environment ( lookupEnv )
 
 import Test.HUnit
 import Test.Hspec
@@ -34,6 +35,7 @@ tests = do
   describe "Boolean Query Engine" $ do
     prop "Parses 'A OR B'" testParse01
     prop "Parses 'A AND B'" testParse02
+    prop "Parses 'A B'" testParse02'
     prop "Parses '-A'" testParse03
     prop "Parses 'NOT A'" testParse03_01
     prop "Parses 'A -B'" testParse04
@@ -46,6 +48,8 @@ tests = do
     prop "It supports 'Raphael'" testParse07_02
     prop "It supports 'Niki', 'Ajeje' and 'Orf'" testParse07_03
     it "Parses words into a single constant" testWordsIntoConst
+    it "Correctly parses partial match queries 01" testPartialMatch01
+    it "Correctly parses partial match queries 02" testPartialMatch02
   describe "Arxiv expression converter" $ do
     it "It supports 'A AND B'"     testArxiv01_01
     it "It supports '\"Haskell\" AND \"Agda\"'" testArxiv01_02
@@ -89,6 +93,9 @@ testParse01 = "A OR B" `translatesInto` (BConst (Positive ["A"]) `BOr` BConst (P
 testParse02 :: Property
 testParse02 = "A AND B" `translatesInto` (BConst (Positive ["A"]) `BAnd` BConst (Positive ["B"]))
 
+testParse02' :: Property
+testParse02' = "A B" `translatesInto` (BConst (Positive ["A"]) `BAnd` BConst (Positive ["B"]))
+
 testParse03 :: Property
 testParse03 = "-A" `translatesInto` (BConst (Negative ["A"]))
 
@@ -146,13 +153,51 @@ testParse07_03 =
 
 testWordsIntoConst :: Assertion
 testWordsIntoConst =
-  let (expected :: BoolExpr [QueryTerm]) = fromCNF (boolTreeToCNF @[QueryTerm] $ (BAnd (BOr (BConst (Positive [QT_exact_match "The",QT_exact_match "Art",QT_exact_match "of",QT_exact_match "Computer",QT_exact_match "Programming"])) BFalse) (BAnd (BOr (BConst (Positive [QT_exact_match "Conceptual",QT_exact_match "Mathematics"])) BFalse) BTrue)))
+  let (expected :: BoolExpr [QueryTerm]) =
+        fromCNF (boolTreeToCNF @[QueryTerm] (
+          BAnd (BOr (BConst (Positive [ QT_exact_match "The"
+                                      , QT_exact_match "Art"
+                                      , QT_exact_match "of"
+                                      , QT_exact_match "Computer"
+                                      , QT_exact_match "Programming" ]))
+                    BFalse)
+               (BAnd (BOr (BConst (Positive [ QT_exact_match "Conceptual"
+                                            , QT_exact_match "Mathematics" ]))
+                          BFalse)
+                     BTrue))
+                )
   in case parseQuery "\"The Art of Computer Programming\" AND \"Conceptual Mathematics\"" of
     Left err
       -> assertBool err False
     Right x
       -> fromCNF (getQuery x) @?= expected
 
+testPartialMatch01 :: Assertion
+testPartialMatch01 =
+  let (expected :: BoolExpr [QueryTerm]) =
+        fromCNF (boolTreeToCNF @[QueryTerm] (
+          BAnd (BConst (Positive [QT_partial_match "fibona"]))
+               (BConst (Positive [QT_exact_match "sequence"])))
+                )
+  in case parseQuery "~fibona AND sequence" of
+    Left err
+      -> assertBool err False
+    Right q
+      -> fromCNF (getQuery q) @?= expected
+
+testPartialMatch02 :: Assertion
+testPartialMatch02 =
+  let (expected :: BoolExpr [QueryTerm]) =
+        fromCNF (boolTreeToCNF @[QueryTerm] (
+          BAnd (BConst (Positive [ QT_partial_match "fibona"
+                                 , QT_exact_match "sequence" ]))
+               BTrue))
+  in case parseQuery "\"~fibona sequence\"" of
+    Left err
+      -> assertBool err False
+    Right q
+      -> fromCNF (getQuery q) @?= expected
+
 withValidQuery :: RawQuery -> (Query -> Assertion) -> Assertion
 withValidQuery rawQuery onValidParse = do
   case parseQuery rawQuery of
@@ -163,38 +208,38 @@ withValidQuery rawQuery onValidParse = do
 testArxiv01_01 :: Assertion
 testArxiv01_01 = withValidQuery "A AND B" $ \q ->
   assertBool ("Query not converted into expression: " <> show @(BoolExpr [QueryTerm]) (fromCNF $ getQuery q))
-             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.And (Arxiv.Exp $ Arxiv.Abs ["A"]) ((Arxiv.Exp $ Arxiv.Abs ["B"]))))
+             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.And (Arxiv.Exp $ Arxiv.Abs ["A"]) (Arxiv.Exp $ Arxiv.Abs ["B"])))
 
 testArxiv01_02 :: Assertion
 testArxiv01_02 = withValidQuery "\"Haskell\" AND \"Agda\"" $ \q ->
   assertBool ("Query not converted into expression: " <> show @(BoolExpr [QueryTerm]) (fromCNF $ getQuery q))
-             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.And (Arxiv.Exp $ Arxiv.Abs ["Haskell"]) ((Arxiv.Exp $ Arxiv.Abs ["Agda"]))))
+             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.And (Arxiv.Exp $ Arxiv.Abs ["Haskell"]) (Arxiv.Exp $ Arxiv.Abs ["Agda"])))
 
 testArxiv02 :: Assertion
 testArxiv02 = withValidQuery "A OR B" $ \q ->
   assertBool ("Query not converted into expression: " <> show @(BoolExpr [QueryTerm]) (fromCNF $ getQuery q))
-             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.Or (Arxiv.Exp $ Arxiv.Abs ["A"]) ((Arxiv.Exp $ Arxiv.Abs ["B"]))))
+             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.Or (Arxiv.Exp $ Arxiv.Abs ["A"]) (Arxiv.Exp $ Arxiv.Abs ["B"])))
 
 testArxiv03_01 :: Assertion
 testArxiv03_01 = withValidQuery "A AND NOT B" $ \q ->
   assertBool ("Query not converted into expression: " <> show @(BoolExpr [QueryTerm]) (fromCNF $ getQuery q))
-             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.AndNot (Arxiv.Exp $ Arxiv.Abs ["A"]) ((Arxiv.Exp $ Arxiv.Abs ["B"]))))
+             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.AndNot (Arxiv.Exp $ Arxiv.Abs ["A"]) (Arxiv.Exp $ Arxiv.Abs ["B"])))
 
 testArxiv03_02 :: Assertion
 testArxiv03_02 = withValidQuery "A AND -B" $ \q ->
   assertBool ("Query not converted into expression: " <> show @(BoolExpr [QueryTerm]) (fromCNF $ getQuery q))
-             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.AndNot (Arxiv.Exp $ Arxiv.Abs ["A"]) ((Arxiv.Exp $ Arxiv.Abs ["B"]))))
+             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.AndNot (Arxiv.Exp $ Arxiv.Abs ["A"]) (Arxiv.Exp $ Arxiv.Abs ["B"])))
 
 -- Double negation get turned into positive.
 testArxiv04_01 :: Assertion
 testArxiv04_01 = withValidQuery "A AND NOT (NOT B)" $ \q ->
   assertBool ("Query not converted into expression: " <> show @(BoolExpr [QueryTerm]) (fromCNF $ getQuery q))
-             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.And (Arxiv.Exp $ Arxiv.Abs ["A"]) ((Arxiv.Exp $ Arxiv.Abs ["B"]))))
+             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.And (Arxiv.Exp $ Arxiv.Abs ["A"]) (Arxiv.Exp $ Arxiv.Abs ["B"])))
 
 testArxiv04_02 :: Assertion
 testArxiv04_02 = withValidQuery "A AND NOT (NOT (NOT B))" $ \q ->
   assertBool ("Query not converted into expression: " <> show @(BoolExpr [QueryTerm]) (fromCNF $ getQuery q))
-             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.AndNot (Arxiv.Exp $ Arxiv.Abs ["A"]) ((Arxiv.Exp $ Arxiv.Abs ["B"]))))
+             (Arxiv.qExp (Arxiv.convertQuery q) == Just (Arxiv.AndNot (Arxiv.Exp $ Arxiv.Abs ["A"]) (Arxiv.Exp $ Arxiv.Abs ["B"])))
 
 testArxiv05 :: Assertion
 testArxiv05 = withValidQuery "A OR NOT B" $ \q ->

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