Generate and commit later ngrams in insertMasterDocs

This commit refactors the flow code to generate the ngrams for
the master docs separately, and then it "commits" them later after such
docs have been associated with a `Node`.

bin/gargantext-cli/CLI/Import.hs

@@ -19,6 +19,7 @@ module CLI.Import where
 
 import CLI.Parsers
 import CLI.Types
+import Control.Monad.Catch (MonadCatch)
 import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..))
 import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
 import Gargantext.API.Errors.Types ( BackendInternalError )
@@ -42,14 +43,14 @@ importCLI (ImportArgs fun user name settingsPath corpusPath) = do
   let
     tt     = Multi EN
     format = TsvGargV3
-    corpus :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    corpus :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, MonadCatch m, JobHandle m ~ DevJobHandle) => m CorpusId
     mkCorpusUser = MkCorpusUserNormalCorpusName (UserName $ cs user) (cs name :: Text)
     corpus = flowCorpusFile mkCorpusUser tt  format Plain corpusPath Nothing DevJobHandle
 
-    corpusTsvHal :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    corpusTsvHal :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, MonadCatch m, JobHandle m ~ DevJobHandle) => m CorpusId
     corpusTsvHal = flowCorpusFile mkCorpusUser tt TsvHal Plain corpusPath Nothing DevJobHandle
 
-    annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
+    annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, MonadCatch m, JobHandle m ~ DevJobHandle) => m CorpusId
     annuaire = flowAnnuaire (MkCorpusUserNormalCorpusName (UserName $ cs user) "Annuaire") (Multi EN) corpusPath DevJobHandle
 
   withDevEnv settingsPath $ \env -> do

gargantext.cabal

@@ -702,6 +702,7 @@ executable gargantext
     , containers ^>= 0.6.7
     , cryptohash ^>= 0.11.9
     , directory ^>= 1.3.7.1
+    , exceptions >= 0.9.0 && < 0.11
     , extra ^>= 1.7.9
     , gargantext
     , gargantext-prelude

src/Gargantext/API/Node/Contact.hs

@@ -18,6 +18,7 @@ module Gargantext.API.Node.Contact
       where
 
 import Conduit ( yield )
+import Control.Monad.Catch (MonadCatch)
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(AuthenticatedUser) )
 import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types ( BackendInternalError )
@@ -57,7 +58,7 @@ apiAsync u nId = Named.ContactAsyncAPI {
                         , _ac_user = u }
     }
 
-addContact :: (FlowCmdM env err m, MonadJobStatus m)
+addContact :: (FlowCmdM env err m, MonadJobStatus m, MonadCatch m)
     => User
     -> NodeId
     -> AddContactParams

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

@@ -24,6 +24,7 @@ module Gargantext.API.Node.Corpus.New
 import Conduit ((.|), yieldMany, mapMC, transPipe)
 import Control.Exception.Safe (MonadMask)
 import Control.Lens ( view, non )
+import Control.Monad.Catch (MonadCatch)
 import Data.Conduit.Internal (zipSources)
 import Data.Conduit.List (mapMaybeM)
 import Data.Swagger ( ToSchema(..) )
@@ -56,6 +57,7 @@ import Gargantext.Database.Admin.Types.Node (CorpusId, NodeType(..), ParentId)
 import Gargantext.Database.GargDB qualified as GargDB
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getNodeWith, getOrMkList)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusIds))
 import Gargantext.Database.Schema.Node (node_hyperdata)
@@ -63,7 +65,6 @@ import Gargantext.Prelude
 import Gargantext.System.Logging ( logLocM, LogLevel(..) )
 import Gargantext.Utils.Jobs.Error (HumanFriendlyErrorText(..))
 import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..))
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 
 ------------------------------------------------------------------------
 {-
@@ -150,6 +151,7 @@ type AddWithFile = Summary "Add with MultipartData to corpus endpoint"
 
 addToCorpusWithQuery :: ( FlowCmdM env err m
                         , MonadJobStatus m
+                        , MonadCatch m
                         )
                        => User
                        -> CorpusId

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

@@ -14,6 +14,7 @@ Portability : POSIX
 module Gargantext.API.Node.Corpus.Searx where
 
 import Control.Lens (view)
+import Control.Monad.Catch (MonadCatch)
 import Data.Aeson qualified as Aeson
 import Data.Text qualified as T
 import Data.Text qualified as Text
@@ -40,6 +41,7 @@ import Gargantext.Database.Query.Table.Node (getOrMkList, insertDefaultNodeIfNot
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Tree.Error (HasTreeError)
 import Gargantext.Prelude
+import Gargantext.System.Logging (MonadLogger)
 import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..))
 import Network.HTTP.Client
 import Network.HTTP.Client.TLS (tlsManagerSettings)
@@ -118,6 +120,8 @@ insertSearxResponse :: ( MonadBase IO m
                        , HasNodeError err
                        , HasTreeError err
                        , HasValidationError err
+                       , MonadCatch m
+                       , MonadLogger m
                        )
                     => User
                     -> CorpusId
@@ -155,6 +159,8 @@ triggerSearxSearch :: ( MonadBase IO m
                       , HasTreeError err
                       , HasValidationError err
                       , MonadJobStatus m
+                      , MonadCatch m
+                      , MonadLogger m
                       )
                    => User
                    -> CorpusId

src/Gargantext/API/Node/DocumentUpload.hs

@@ -16,6 +16,7 @@ Portability : POSIX
 module Gargantext.API.Node.DocumentUpload where
 
 import Control.Lens (view)
+import Control.Monad.Catch (MonadCatch)
 import Data.Text qualified as T
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..))
 import Gargantext.API.Admin.EnvTypes (Env)
@@ -32,16 +33,16 @@ import Gargantext.Core.NodeStory.Types (HasNodeStoryEnv)
 import Gargantext.Core.Text.Corpus.Parsers.Date (mDateSplit)
 import Gargantext.Core.Text.Terms (TermType(..))
 import Gargantext.Core.Types.Individu (User(..))
-import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
 import Gargantext.Core.Worker.Jobs.Types (WorkSplit(..))
+import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
 import Gargantext.Database.Action.Flow (addDocumentsToHyperCorpus)
 import Gargantext.Database.Action.Flow.Types ( FlowCmdM )
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataCorpus )
 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
 import Gargantext.Database.Admin.Types.Node ( DocId, NodeId, NodeType(NodeCorpus), ParentId )
 import Gargantext.Database.Prelude
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType')
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Schema.Node (_node_hyperdata)
 import Gargantext.Prelude
 import Gargantext.System.Logging (logLocM, LogLevel(..), MonadLogger)
@@ -55,7 +56,7 @@ api nId = Named.DocumentUploadAPI {
                             , _ud_node_id = nId }
   }
 
-documentUploadAsync :: (FlowCmdM env err m, MonadJobStatus m)
+documentUploadAsync :: (FlowCmdM env err m, MonadJobStatus m, MonadCatch m)
                => NodeId
                -> DocumentUpload
                -> JobHandle m
@@ -66,7 +67,7 @@ documentUploadAsync nId doc jobHandle = do
   -- printDebug "documentUploadAsync" docIds
   markComplete jobHandle
 
-documentUpload :: (FlowCmdM env err m)
+documentUpload :: (FlowCmdM env err m, MonadCatch m)
                => NodeId
                -> DocumentUpload
                -> m [DocId]
@@ -110,6 +111,7 @@ remoteImportDocuments :: ( HasNodeError err
                          , HasNodeStoryEnv env err
                          , IsDBCmd env err m
                          , MonadLogger m
+                         , MonadCatch m
                          , MonadIO m)
                       => AuthenticatedUser
                       -> ParentId

src/Gargantext/API/Node/DocumentsFromWriteNodes.hs

@@ -17,6 +17,8 @@ module Gargantext.API.Node.DocumentsFromWriteNodes
       where
 
 import Conduit ( yieldMany )
+import Control.Lens (view)
+import Control.Monad.Catch (MonadCatch)
 import Data.List qualified as List
 import Data.Text qualified as T
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser, auth_node_id, auth_user_id )
@@ -39,15 +41,14 @@ import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
 import Gargantext.Database.Admin.Types.Hyperdata.Frame ( HyperdataFrame(..), getHyperdataFrameContents )
 import Gargantext.Database.Admin.Types.Node ( NodeId, Node, NodeType(..) )
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getChildrenByType, getClosestParentIdByType', getNodeWith, getOrMkList)
 import Gargantext.Database.Schema.Node (node_hyperdata, node_name, node_date)
-import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Gargantext.System.Logging (logLocM, LogLevel(..))
-import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Gargantext.Utils.Jobs.Error (HumanFriendlyErrorText(..))
+import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Servant.Server.Generic (AsServerT)
-import Control.Lens (view)
 
 api :: AuthenticatedUser
     -- ^ The logged-in user
@@ -63,6 +64,7 @@ api authenticatedUser nId =
 
 documentsFromWriteNodes :: ( FlowCmdM env err m
                            , MonadJobStatus m
+                           , MonadCatch m
                            )
                         => AuthenticatedUser
                         -- ^ The logged-in user

src/Gargantext/Database/Admin/Types/Node.hs

@@ -292,7 +292,7 @@ instance ToSchema NodeId
 -- | An identifier for a 'Context' in gargantext.
 newtype ContextId = UnsafeMkContextId { _ContextId :: Int }
   deriving stock   (Show, Eq, Ord, Generic)
-  deriving newtype (Csv.ToField, ToJSONKey, FromJSONKey, ToJSON, FromJSON, ToField, ToSchema)
+  deriving newtype (Csv.ToField, ToJSONKey, FromJSONKey, ToJSON, FromJSON, ToField, ToSchema, Hashable)
   deriving anyclass ToExpr
   deriving FromField via NodeId
 

test/Test/Database/Types.hs

@@ -11,6 +11,7 @@ Portability : POSIX
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans      #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Test.Database.Types where
 
@@ -24,6 +25,7 @@ import Data.Map qualified as Map
 import Data.Pool
 import Database.PostgreSQL.Simple qualified as PG
 import Database.Postgres.Temp qualified as Tmp
+import GHC.IO.Exception (userError)
 import Gargantext hiding (to)
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Errors.Types
@@ -33,13 +35,12 @@ import Gargantext.Core.Config.Mail (MailConfig(..), LoginType(NoAuth), SendEmail
 import Gargantext.Core.Mail.Types (HasMail(..))
 import Gargantext.Core.NLP (HasNLPServer(..))
 import Gargantext.Core.NodeStory
-import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..))
+import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..), LogLevel(..))
 import Gargantext.System.Logging.Loggers
 import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
 import Network.URI (parseURI)
 import Prelude qualified
 import System.Log.FastLogger qualified as FL
-import GHC.IO.Exception (userError)
 
 
 newtype Counter = Counter { _Counter :: IORef Int }
@@ -75,6 +76,19 @@ newtype TestMonadM env err a = TestMonad { _TestMonad :: ReaderT env IO a }
            , MonadThrow
            )
 
+instance HasLogger (TestMonadM TestEnv BackendInternalError) where
+  data instance Logger (TestMonadM TestEnv BackendInternalError)        = TestLogger { _IOLogger :: IOStdLogger }
+  type instance LogInitParams (TestMonadM TestEnv BackendInternalError) = LogConfig
+  type instance LogPayload (TestMonadM TestEnv BackendInternalError)    = Prelude.String
+  initLogger cfg = fmap TestLogger $ (liftIO $ ioStdLogger cfg)
+  destroyLogger = liftIO . _iosl_destroy . _IOLogger
+  logMsg (TestLogger ioLogger) lvl msg = liftIO $ _iosl_log_msg ioLogger lvl msg
+  logTxt (TestLogger ioLogger) lvl msg = liftIO $ _iosl_log_txt ioLogger lvl msg
+
+instance MonadLogger (TestMonadM TestEnv BackendInternalError) where
+  getLogger = TestMonad $ do
+    initLogger @(TestMonadM TestEnv BackendInternalError) (LogConfig Nothing ERROR)
+
 runTestMonadM :: env -> TestMonadM env err a -> IO a
 runTestMonadM env = flip runReaderT env . _TestMonad