[refactor] addDocumentsToHyperCorpus can use HasNLPServer instance

All calls were basically:

nlpServer <- view (nlpServerGet lang)
addDocumentsToHyperCorpus nlpServer ...
parent 7fad2fc3
...@@ -23,7 +23,7 @@ import Data.Tuple.Select (sel1, sel2, sel3) ...@@ -23,7 +23,7 @@ import Data.Tuple.Select (sel1, sel2, sel3)
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.Core.Config (GargConfig(..), hasConfig) import Gargantext.Core.Config (GargConfig(..), hasConfig)
import Gargantext.Core.Config.Types (FramesConfig(..)) import Gargantext.Core.Config.Types (FramesConfig(..))
import Gargantext.Core.NLP (HasNLPServer, nlpServerGet) import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.NodeStory.Types ( HasNodeStory ) import Gargantext.Core.NodeStory.Types ( HasNodeStory )
import Gargantext.Core.Text.Corpus.Query qualified as Query import Gargantext.Core.Text.Corpus.Query qualified as Query
import Gargantext.Core.Text.Terms (TermType(..)) import Gargantext.Core.Text.Terms (TermType(..))
...@@ -126,7 +126,6 @@ insertSearxResponse :: ( MonadBase IO m ...@@ -126,7 +126,6 @@ insertSearxResponse :: ( MonadBase IO m
-> m () -> m ()
insertSearxResponse _ _ _ _ (Left _) = pure () insertSearxResponse _ _ _ _ (Left _) = pure ()
insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) = do insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) = do
server <- view (nlpServerGet l)
-- docs :: [Either Text HyperdataDocument] -- docs :: [Either Text HyperdataDocument]
let docs = hyperdataDocumentFromSearxResult l <$> _srs_results let docs = hyperdataDocumentFromSearxResult l <$> _srs_results
--printDebug "[triggerSearxSearch] docs" docs --printDebug "[triggerSearxSearch] docs" docs
...@@ -141,7 +140,7 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) = ...@@ -141,7 +140,7 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) =
-} -}
--_ <- flowDataText user (DataNew [docs']) (Multi l) cId Nothing logStatus --_ <- flowDataText user (DataNew [docs']) (Multi l) cId Nothing logStatus
let mCorpus = Nothing :: Maybe HyperdataCorpus let mCorpus = Nothing :: Maybe HyperdataCorpus
void $ addDocumentsToHyperCorpus server mCorpus (Multi l) cId docs' void $ addDocumentsToHyperCorpus mCorpus (Multi l) cId docs'
_ <- buildSocialList l user cId listId mCorpus Nothing _ <- buildSocialList l user cId listId mCorpus Nothing
......
...@@ -27,7 +27,7 @@ import Gargantext.API.Prelude ( GargM ) ...@@ -27,7 +27,7 @@ import Gargantext.API.Prelude ( GargM )
import Gargantext.API.Routes.Named.Document qualified as Named import Gargantext.API.Routes.Named.Document qualified as Named
import Gargantext.API.Worker (serveWorkerAPI) import Gargantext.API.Worker (serveWorkerAPI)
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.Core.NLP (nlpServerGet, HasNLPServer) import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.NodeStory.Types (HasNodeStoryEnv, HasNodeArchiveStoryImmediateSaver) import Gargantext.Core.NodeStory.Types (HasNodeStoryEnv, HasNodeArchiveStoryImmediateSaver)
import Gargantext.Core.Text.Corpus.Parsers.Date (mDateSplit) import Gargantext.Core.Text.Corpus.Parsers.Date (mDateSplit)
import Gargantext.Core.Text.Terms (TermType(..)) import Gargantext.Core.Text.Terms (TermType(..))
...@@ -99,8 +99,7 @@ documentUpload nId doc = do ...@@ -99,8 +99,7 @@ documentUpload nId doc = do
, _hd_institutes_tree = Nothing } , _hd_institutes_tree = Nothing }
let lang = EN let lang = EN
ncs <- view $ nlpServerGet lang addDocumentsToHyperCorpus (Nothing :: Maybe HyperdataCorpus) (Multi lang) cId [hd]
addDocumentsToHyperCorpus ncs (Nothing :: Maybe HyperdataCorpus) (Multi lang) cId [hd]
-- | Imports the documents contained into this 'DocumentExport' into this (local) version -- | Imports the documents contained into this 'DocumentExport' into this (local) version
-- of the running node. -- of the running node.
...@@ -122,9 +121,8 @@ remoteImportDocuments :: ( HasNodeError err ...@@ -122,9 +121,8 @@ remoteImportDocuments :: ( HasNodeError err
-> m [NodeId] -> m [NodeId]
remoteImportDocuments loggedInUser corpusId nodeId WorkSplit{..} documents = do remoteImportDocuments loggedInUser corpusId nodeId WorkSplit{..} documents = do
let la = Multi EN let la = Multi EN
nlpServerConfig <- view $ nlpServerGet (_tt_lang la)
$(logLocM) INFO $ "Importing " <> T.pack (show _ws_current) <> "/" <> T.pack (show _ws_total) <> " documents for corpus node " <> T.pack (show nodeId) $(logLocM) INFO $ "Importing " <> T.pack (show _ws_current) <> "/" <> T.pack (show _ws_total) <> " documents for corpus node " <> T.pack (show nodeId)
docs <- addDocumentsToHyperCorpus nlpServerConfig (Nothing :: Maybe HyperdataCorpus) la corpusId (map (_node_hyperdata . _d_document) documents) docs <- addDocumentsToHyperCorpus (Nothing :: Maybe HyperdataCorpus) la corpusId (map (_node_hyperdata . _d_document) documents)
_versioned <- commitCorpus corpusId (RootId $ _auth_node_id loggedInUser) _versioned <- commitCorpus corpusId (RootId $ _auth_node_id loggedInUser)
$(logLocM) INFO $ "Done importing " <> T.pack (show _ws_current) <> "/" <> T.pack (show _ws_total) <> " documents for corpus node " <> T.pack (show nodeId) $(logLocM) INFO $ "Done importing " <> T.pack (show _ws_current) <> "/" <> T.pack (show _ws_total) <> " documents for corpus node " <> T.pack (show nodeId)
pure docs pure docs
...@@ -274,10 +274,9 @@ flow :: forall env err m a c. ...@@ -274,10 +274,9 @@ flow :: forall env err m a c.
flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do
(_userId, userCorpusId, listId) <- createNodes mkCorpusUser c (_userId, userCorpusId, listId) <- createNodes mkCorpusUser c
-- TODO if public insertMasterDocs else insertUserDocs -- TODO if public insertMasterDocs else insertUserDocs
nlpServer <- view $ nlpServerGet (_tt_lang la)
runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC
.| CList.chunksOf 5 .| CList.chunksOf 5
.| mapM_C (addDocumentsWithProgress nlpServer userCorpusId) .| mapM_C (addDocumentsWithProgress userCorpusId)
.| sinkNull .| sinkNull
let u = userFromMkCorpusUser mkCorpusUser let u = userFromMkCorpusUser mkCorpusUser
...@@ -286,10 +285,10 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do ...@@ -286,10 +285,10 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do
flowCorpusUser (la ^. tt_lang) u userCorpusId listId c mfslw flowCorpusUser (la ^. tt_lang) u userCorpusId listId c mfslw
where where
addDocumentsWithProgress :: NLPServerConfig -> CorpusId -> [(Int, a)] -> m () addDocumentsWithProgress :: CorpusId -> [(Int, a)] -> m ()
addDocumentsWithProgress nlpServer userCorpusId docsChunk = do addDocumentsWithProgress userCorpusId docsChunk = do
$(logLocM) DEBUG $ T.pack $ "calling insertDoc, ([idx], mLength) = " <> show (fst <$> docsChunk, count) $(logLocM) DEBUG $ T.pack $ "calling insertDoc, ([idx], mLength) = " <> show (fst <$> docsChunk, count)
docs <- addDocumentsToHyperCorpus nlpServer c la userCorpusId (map snd docsChunk) docs <- addDocumentsToHyperCorpus c la userCorpusId (map snd docsChunk)
markProgress (length docs) jobHandle markProgress (length docs) jobHandle
...@@ -297,17 +296,18 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do ...@@ -297,17 +296,18 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do
-- the given documents to the corpus. Returns the Ids of the inserted documents. -- the given documents to the corpus. Returns the Ids of the inserted documents.
addDocumentsToHyperCorpus :: ( IsDBCmd env err m addDocumentsToHyperCorpus :: ( IsDBCmd env err m
, HasNodeError err , HasNodeError err
, HasNLPServer env
, FlowCorpus document , FlowCorpus document
, MkCorpus corpus , MkCorpus corpus
) )
=> NLPServerConfig => Maybe corpus
-> Maybe corpus
-> TermType Lang -> TermType Lang
-> CorpusId -> CorpusId
-> [document] -> [document]
-> m [DocId] -> m [DocId]
addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do addDocumentsToHyperCorpus mb_hyper la corpusId docs = do
ids <- insertMasterDocs ncs mb_hyper la docs nlpServer <- view $ nlpServerGet (_tt_lang la)
ids <- insertMasterDocs nlpServer mb_hyper la docs
void $ Doc.add corpusId (map nodeId2ContextId ids) void $ Doc.add corpusId (map nodeId2ContextId ids)
pure ids pure ids
......
...@@ -3,7 +3,6 @@ ...@@ -3,7 +3,6 @@
module Test.API.Export (tests) where module Test.API.Export (tests) where
import Control.Lens (view)
import Data.ByteString.Lazy qualified as BSL import Data.ByteString.Lazy qualified as BSL
import Data.Version (showVersion) import Data.Version (showVersion)
import Database.SQLite.Simple qualified as S import Database.SQLite.Simple qualified as S
...@@ -11,7 +10,6 @@ import Database.SQLite.Simple qualified as S ...@@ -11,7 +10,6 @@ import Database.SQLite.Simple qualified as S
import Gargantext.API.Node.Corpus.Export.Types (CorpusSQLite(..), CorpusSQLiteData(..)) import Gargantext.API.Node.Corpus.Export.Types (CorpusSQLite(..), CorpusSQLiteData(..))
import Gargantext.API.Node.Corpus.Export.Utils (withTempSQLiteDir, mkCorpusSQLiteData) import Gargantext.API.Node.Corpus.Export.Utils (withTempSQLiteDir, mkCorpusSQLiteData)
import Gargantext.Core (Lang(EN)) import Gargantext.Core (Lang(EN))
import Gargantext.Core.NLP (nlpServerGet)
import Gargantext.Core.Text.Terms (TermType(Multi)) import Gargantext.Core.Text.Terms (TermType(Multi))
import Gargantext.Core.Types (unNodeId) import Gargantext.Core.Types (unNodeId)
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
...@@ -55,8 +53,7 @@ tests = sequential $ around withTestDBAndPort $ beforeWith dbEnvSetup $ do ...@@ -55,8 +53,7 @@ tests = sequential $ around withTestDBAndPort $ beforeWith dbEnvSetup $ do
let docs = [ exampleDocument_01, exampleDocument_02 ] let docs = [ exampleDocument_01, exampleDocument_02 ]
let lang = EN let lang = EN
nlpServer <- view (nlpServerGet lang) _ <- addDocumentsToHyperCorpus (Just $ corpus ^. node_hyperdata) (Multi lang) corpusId docs
_ <- addDocumentsToHyperCorpus nlpServer (Just $ corpus ^. node_hyperdata) (Multi lang) corpusId docs
(CorpusSQLiteData { .. }) <- mkCorpusSQLiteData corpusId Nothing (CorpusSQLiteData { .. }) <- mkCorpusSQLiteData corpusId Nothing
......
...@@ -12,15 +12,11 @@ Portability : POSIX ...@@ -12,15 +12,11 @@ Portability : POSIX
module Test.Database.Operations.DocumentSearch where module Test.Database.Operations.DocumentSearch where
-- import Gargantext.API.Node.Update (updateDocs)
-- import Network.URI (parseURI)
import Control.Lens (view)
import Control.Monad.Reader import Control.Monad.Reader
import Data.Aeson.QQ.Simple import Data.Aeson.QQ.Simple
import Data.Aeson.Types import Data.Aeson.Types
import Data.Text qualified as T import Data.Text qualified as T
import Gargantext.Core import Gargantext.Core
import Gargantext.Core.NLP (nlpServerGet)
import Gargantext.Core.Text.Corpus.Query qualified as API import Gargantext.Core.Text.Corpus.Query qualified as API
import Gargantext.Core.Text.Terms.Mono.Stem import Gargantext.Core.Text.Terms.Mono.Stem
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
...@@ -122,9 +118,7 @@ addCorpusDocuments env = flip runReaderT env $ runTestMonad $ do ...@@ -122,9 +118,7 @@ addCorpusDocuments env = flip runReaderT env $ runTestMonad $ do
let lang = EN let lang = EN
let docs = [exampleDocument_01, exampleDocument_02, exampleDocument_03, exampleDocument_04] let docs = [exampleDocument_01, exampleDocument_02, exampleDocument_03, exampleDocument_04]
server <- view (nlpServerGet lang) _ <- addDocumentsToHyperCorpus (Just $ _node_hyperdata $ corpus)
_ <- addDocumentsToHyperCorpus server
(Just $ _node_hyperdata $ corpus)
(Multi lang) (Multi lang)
corpusId corpusId
docs docs
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment