WIP

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

@@ -39,7 +39,7 @@ import Gargantext.API.Node.Types
 import Gargantext.Core (withDefaultLanguage, defaultLanguage)
 import Gargantext.Core.Config (gc_jobs, hasConfig)
 import Gargantext.Core.Config.Types (jc_max_docs_parsers)
-import Gargantext.Core.NodeStory (HasNodeStoryImmediateSaver, HasNodeArchiveStoryImmediateSaver, currentVersion, NgramsStatePatch', HasNodeStoryEnv)
+import Gargantext.Core.NodeStory (currentVersion, NgramsStatePatch', HasNodeStoryEnv)
 import Gargantext.Core.Text.Corpus.Parsers qualified as Parser (FileType(..), parseFormatC, _ParseFormatError)
 import Gargantext.Core.Text.Corpus.Parsers.Types
 import Gargantext.Core.Text.Corpus.Query qualified as API
@@ -150,8 +150,6 @@ type AddWithFile = Summary "Add with MultipartData to corpus endpoint"
 
 addToCorpusWithQuery :: ( FlowCmdM env err m
                         , MonadJobStatus m
-                        , HasNodeStoryImmediateSaver env
-                        , HasNodeArchiveStoryImmediateSaver env
                         )
                        => User
                        -> CorpusId
@@ -221,8 +219,6 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
 addToCorpusWithTempFile :: ( MonadMask m
                            , FlowCmdM env err m
                            , MonadJobStatus m
-                           , HasNodeStoryImmediateSaver env
-                           , HasNodeArchiveStoryImmediateSaver env
                            )
                         => User
                         -> CorpusId
@@ -372,10 +368,7 @@ addToCorpusWithFile user cid nwf@(NewWithFile _d (withDefaultLanguage -> l) fNam
 --- UTILITIES
 
 commitCorpus :: ( IsDBCmd env err m
-                , HasNodeStoryEnv env
-                , HasNodeError err
-                , HasNodeArchiveStoryImmediateSaver env
-                , HasNodeStoryImmediateSaver env )
+                )
              => ParentId
              -> User
              -> m (Versioned NgramsStatePatch')

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

@@ -35,6 +35,7 @@ import Gargantext.Database.Action.User (getUserId)
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus)
 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
 import Gargantext.Database.Admin.Types.Node (CorpusId, ListId, NodeType(NodeTexts))
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getOrMkList, insertDefaultNodeIfNotExists)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Tree.Error (HasTreeError)
@@ -146,7 +147,6 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) =
 
   pure ()
 
-  
 -- TODO Make an async task out of this?
 triggerSearxSearch :: ( MonadBase IO m
                       , HasNodeStory env err m
@@ -163,9 +163,9 @@ triggerSearxSearch :: ( MonadBase IO m
                    -> JobHandle m
                    -> m ()
 triggerSearxSearch user cId q l jobHandle = do
-  userId <- getUserId user
-
-  _tId <- insertDefaultNodeIfNotExists NodeTexts cId userId
+  runDBTx $ do
+    userId <- getUserId user
+    void $ insertDefaultNodeIfNotExists NodeTexts cId userId
 
   let numPages = 100
   markStarted numPages jobHandle
@@ -174,10 +174,12 @@ triggerSearxSearch user cId q l jobHandle = do
   -- printDebug "[triggerSearxSearch] q" q
   -- printDebug "[triggerSearxSearch] l" l
   cfg <- view hasConfig
-  uId <- getUserId user
   let surl = _f_searx_url $ _gc_frames cfg
-  -- printDebug "[triggerSearxSearch] surl" surl
-  listId <- getOrMkList cId uId
+
+  listId <- runDBTx $ do
+    uId <- getUserId user
+    -- printDebug "[triggerSearxSearch] surl" surl
+    getOrMkList cId uId
 
   -- printDebug "[triggerSearxSearch] listId" listId
 

src/Gargantext/Database/Action/Flow.hs

@@ -23,6 +23,7 @@ Portability : POSIX
 {-# LANGUAGE TypeApplications        #-}
 {-# LANGUAGE TypeOperators           #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
 
 module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
   ( DataText(..)
@@ -317,8 +318,8 @@ addDocumentsToHyperCorpus :: ( IsDBCmd env err m
 addDocumentsToHyperCorpus mb_hyper la corpusId docs = do
   cfg <- view hasConfig
   nlp <- view (nlpServerGet $ _tt_lang la)
+  ids <- insertMasterDocs cfg nlp mb_hyper la docs
   runDBTx $ do
-    ids <- insertMasterDocs cfg nlp mb_hyper la docs
     void $ Doc.add corpusId (map nodeId2ContextId ids)
     pure ids
 
@@ -364,12 +365,9 @@ flowCorpusUser :: ( HasNodeError err
                -> Maybe FlowSocialListWith
                -> m CorpusId
 flowCorpusUser l user userCorpusId listId ctype mfslw = do
-  cfg <- view hasConfig
   env <- view hasNodeStory
-  nlpServer <- view (nlpServerGet l)
+  buildSocialList l user userCorpusId listId ctype mfslw
   runDBTx $ do
-    buildSocialList cfg nlpServer l user userCorpusId listId ctype mfslw
-
     -- _ <- insertOccsUpdates userCorpusId mastListId
     --_ <- mkPhylo  userCorpusId userId
     -- Annuaire Flow
@@ -385,48 +383,59 @@ flowCorpusUser l user userCorpusId listId ctype mfslw = do
 buildSocialList :: ( HasNodeError err
                    , HasValidationError err
                    , HasTreeError err
+                   , HasNodeStory env err m
                    , MkCorpus c
+                   , HasNLPServer env
                    )
-                => GargConfig
-                -> NLPServerConfig
-                -> Lang
+                => Lang
                 -> User
                 -> CorpusId
                 -> ListId
                 -> Maybe c
                 -> Maybe FlowSocialListWith
-                -> DBUpdate err ()
-buildSocialList cfg nlpServer l user userCorpusId listId ctype = \case
+                -> m ()
+buildSocialList l user userCorpusId listId ctype = \case
   Just (NoList _) -> pure ()
   mfslw -> do
-    -- User List Flow
-    (masterUserId, _masterRootId, masterCorpusId)
-      <- getOrMkRootWithCorpus cfg MkCorpusUserMaster ctype
+    cfg <- view hasConfig
+    nlpServer <- view (nlpServerGet l)
+    (masterUserId, masterCorpusId, ngs) <- runDBTx $ do
+      -- User List Flow
+      (master_user_id, _masterRootId, master_corpus_id)
+        <- getOrMkRootWithCorpus cfg MkCorpusUserMaster ctype
 
-    let gp = GroupWithPosTag l nlpServer HashMap.empty
-    ngs  <- buildNgramsLists user userCorpusId masterCorpusId mfslw gp
+      let gp = GroupWithPosTag l nlpServer HashMap.empty
+      (master_user_id, master_corpus_id,) <$> buildNgramsLists user userCorpusId master_corpus_id mfslw gp
 
     -- printDebug "flowCorpusUser:ngs" ngs
 
     _userListId <- flowList_DbRepo listId ngs
-    _mastListId <- getOrMkList masterCorpusId masterUserId
+    _mastListId <- runDBTx $ getOrMkList masterCorpusId masterUserId
     pure ()
 
 
+-- FIME(adn): the use of 'extractNgramsT' is iffy and problematic -- we shouldn't
+-- be contacting the NLP server in the middle of some DB ops! we should extract
+-- the tokens /before/ inserting things into the DB.
 insertMasterDocs :: ( HasNodeError err
                     , FlowCorpus a
                     , MkCorpus   c
+                    , IsDBCmd env err m
                     )
                  => GargConfig
                  -> NLPServerConfig
                  -> Maybe c
                  -> TermType Lang
                  -> [a]
-                 -> DBUpdate err [DocId]
+                 -> m [DocId]
 insertMasterDocs cfg nlpServer c lang hs  =  do
-  (masterUserId, _, masterCorpusId) <- getOrMkRootWithCorpus cfg MkCorpusUserMaster c
-  (ids', documentsWithId) <- insertDocs masterUserId masterCorpusId (map (toNode masterUserId Nothing) hs )
-  _ <- Doc.add masterCorpusId ids'
+
+  (masterUserId, masterCorpusId, documentsWithId, ids') <- runDBTx $ do
+    (master_user_id, _, master_corpus_id) <- getOrMkRootWithCorpus cfg MkCorpusUserMaster c
+    (ids_prime, documents_with_id) <- insertDocs master_user_id master_corpus_id (map (toNode master_user_id Nothing) hs )
+    _ <- Doc.add master_corpus_id ids_prime
+    pure (master_user_id, master_corpus_id, documents_with_id, ids_prime)
+
   -- TODO
   -- create a corpus with database name (CSV or PubMed)
   -- add documents to the corpus (create node_node link)
@@ -438,10 +447,10 @@ insertMasterDocs cfg nlpServer c lang hs  =  do
                       (extractNgramsT nlpServer $ withLang lang documentsWithId)
                       (map (B.first contextId2NodeId) documentsWithId)
 
-  lId <- getOrMkList masterCorpusId masterUserId
-  _ <- saveDocNgramsWith lId mapNgramsDocs'
-
-  pure $ map contextId2NodeId ids'
+  runDBTx $ do
+    lId <- getOrMkList masterCorpusId masterUserId
+    _ <- saveDocNgramsWith lId mapNgramsDocs'
+    pure $ map contextId2NodeId ids'
 
 
 saveDocNgramsWith :: ListId

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

@@ -87,9 +87,9 @@ docNgrams lang ts doc =
 
 documentIdWithNgrams :: HasNodeError err
                      => ( a
-                       -> DBTx err r (HashMap.HashMap b (Map NgramsType TermsWeight, TermsCount)) )
+                       -> DBCmd err (HashMap.HashMap b (Map NgramsType TermsWeight, TermsCount)) )
                      -> [Indexed NodeId a]
-                     -> DBTx err r [DocumentIdWithNgrams a b]
+                     -> DBCmd err [DocumentIdWithNgrams a b]
 documentIdWithNgrams f = traverse toDocumentIdWithNgrams
   where
     toDocumentIdWithNgrams d = do

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

@@ -34,13 +34,14 @@ import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.Flow (getOrMkRoot)
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (DBCmd, DBCmdExtra, IsDBCmdExtra, DBCmdWithEnv)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, 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
@@ -78,8 +79,10 @@ new_users :: (HasNodeError err)
           -> DBCmdWithEnv env err (NonEmpty UserId)
 new_users us = do
   us'   <- liftBase        $ mapM toUserHash us
-  void  $ insertUsers      $ NE.map toUserWrite us'
-  mapM (fmap fst . getOrMkRoot) $ NE.map  (\u -> UserName   (_nu_username u)) us
+  cfg   <- view hasConfig
+  runDBTx $ do
+    void  $ insertUsers      $ NE.map toUserWrite us'
+    mapM (fmap fst . getOrMkRoot cfg) $ NE.map  (\u -> UserName   (_nu_username u)) us
 
 ------------------------------------------------------------------------
 newUsers :: (IsDBCmdExtra env err m, MonadRandom m, HasNodeError err, HasMail env)
@@ -110,11 +113,13 @@ guessUserName n = case splitOn "@" n of
 ------------------------------------------------------------------------
 newUsers' :: (HasNodeError err)
          => MailConfig -> NonEmpty (NewUser GargPassword) -> DBCmdWithEnv env err (NonEmpty UserId)
-newUsers' cfg us = do
+newUsers' mcfg us = do
   us' <- liftBase         $ mapM toUserHash  us
-  void $ insertUsers      $ NE.map  toUserWrite us'
-  urs <- mapM (fmap fst . getOrMkRoot) $ map  (\u -> UserName   (_nu_username u)) us
-  _   <- mapM (\u -> mail cfg (Invitation u)) us
+  cfg <- view hasConfig
+  urs <- runDBTx $ do
+    void $ insertUsers      $ NE.map  toUserWrite us'
+    mapM (fmap fst . getOrMkRoot cfg) $ map  (\u -> UserName   (_nu_username u)) us
+  _   <- mapM (\u -> mail mcfg (Invitation u)) us
   -- printDebug "newUsers'" us
   pure urs
 
@@ -124,7 +129,7 @@ updateUser :: HasNodeError err
             => SendEmail -> MailConfig -> NewUser GargPassword -> DBCmdExtra err Int64
 updateUser (SendEmail send) cfg u = do
   u' <- liftBase     $ toUserHash   u
-  n  <- updateUserDB $ toUserWrite  u'
+  n  <- runDBTx $ updateUserDB $ toUserWrite  u'
   when send $ mail cfg (PassUpdate u)
   pure n
 
@@ -138,7 +143,7 @@ _updateUsersPassword us = do
   pure 1
 
 ------------------------------------------------------------------------
-_rmUser :: HasNodeError err => User -> DBCmd err Int64
+_rmUser :: HasNodeError err => User -> DBUpdate err Int64
 _rmUser (UserName un) = deleteUsers [un]
 _rmUser _ = nodeError NotImplYet