Skip to content

haskell-gargantext
haskell-gargantext
Verified Commit beb78a05 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

[refactor] getOrMkRootWithCorpus with custom datatype 

This was (User, Either CorpusName, [CorpusId]) before, but the case of
UserMaster doesn't make sense with these parameters, so I rewrote the
function to accept only correct datatypes as inputs.
parent ac11395a
Hide whitespace changes
Inline Side-by-side
Showing with 123 additions and 104 deletions
bin/gargantext-import/Main.hs
View file @ beb78a05
...@@ -15,22 +15,22 @@ Import a corpus binary. ...@@ -15,22 +15,22 @@ Import a corpus binary.
module Main where module Main where
import Data.Either import Data.Text qualified as Text
import qualified Data.Text as Text
import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..)) import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..))
import Gargantext.API.Errors.Types import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
import Gargantext.API.Errors.Types ( BackendInternalError )
import Gargantext.API.Node () -- instances import Gargantext.API.Node () -- instances
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..))
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Query (Limit) import Gargantext.Core.Types.Query (Limit)
import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..)) import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..))
import Gargantext.Database.Action.Flow.Types (FlowCmdM) import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Admin.Types.Node (CorpusId) import Gargantext.Database.Admin.Types.Node (CorpusId)
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusName))
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..)) import Gargantext.Utils.Jobs.Monad ( MonadJobStatus, JobHandle )
import Gargantext.Utils.Jobs (MonadJobStatus, JobHandle)
main :: IO () main :: IO ()
main = do main = do
...@@ -46,13 +46,14 @@ main = do ...@@ -46,13 +46,14 @@ main = do
Nothing -> panicTrace $ "Cannot read limit: " <> (Text.pack limit) Nothing -> panicTrace $ "Cannot read limit: " <> (Text.pack limit)
Just l -> l Just l -> l
corpus :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId corpus :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt format Plain corpusPath Nothing DevJobHandle mkCorpusUser = MkCorpusUserNormalCorpusName (UserName $ cs user) (cs name :: Text)
corpus = flowCorpusFile mkCorpusUser limit' tt format Plain corpusPath Nothing DevJobHandle
corpusCsvHal :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId corpusCsvHal :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) limit' tt CsvHal Plain corpusPath Nothing DevJobHandle corpusCsvHal = flowCorpusFile mkCorpusUser limit' tt CsvHal 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, JobHandle m ~ DevJobHandle) => m CorpusId
annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath DevJobHandle annuaire = flowAnnuaire (MkCorpusUserNormalCorpusName (UserName $ cs user) "Annuaire") (Multi EN) corpusPath DevJobHandle
{- {-
let debatCorpus :: forall m. FlowCmdM DevEnv BackendInternalError m => m CorpusId let debatCorpus :: forall m. FlowCmdM DevEnv BackendInternalError m => m CorpusId
......
bin/gargantext-init/Main.hs
View file @ beb78a05
...@@ -15,21 +15,21 @@ Import a corpus binary. ...@@ -15,21 +15,21 @@ Import a corpus binary.
module Main where module Main where
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.Errors.Types
import Gargantext.API.Node () -- instances only import Gargantext.API.Node () -- instances only
import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..)) import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..))
import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMk_RootWithCorpus) import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMkRootWithCorpus)
import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers) import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, DBCmd) import Gargantext.Database.Prelude (Cmd, DBCmd)
import Gargantext.Database.Query.Table.Node (getOrMkList) import Gargantext.Database.Query.Table.Node (getOrMkList)
import Gargantext.Database.Query.Table.User (insertNewUsers, ) import Gargantext.Database.Query.Table.User (insertNewUsers, )
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserMaster))
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..), readConfig) import Gargantext.Prelude.Config (GargConfig(..), readConfig)
import qualified Data.List.NonEmpty as NE
main :: IO () main :: IO ()
...@@ -63,8 +63,7 @@ main = do ...@@ -63,8 +63,7 @@ main = do
initMaster :: Cmd BackendInternalError (UserId, RootId, CorpusId, ListId) initMaster :: Cmd BackendInternalError (UserId, RootId, CorpusId, ListId)
initMaster = do initMaster = do
(masterUserId, masterRootId, masterCorpusId) (masterUserId, masterRootId, masterCorpusId)
<- getOrMk_RootWithCorpus (UserName userMaster) <- getOrMkRootWithCorpus MkCorpusUserMaster
(Left corpusMasterName)
(Nothing :: Maybe HyperdataCorpus) (Nothing :: Maybe HyperdataCorpus)
masterListId <- getOrMkList masterCorpusId masterUserId masterListId <- getOrMkList masterCorpusId masterUserId
_triggers <- initLastTriggers masterListId _triggers <- initLastTriggers masterListId
......
src/Gargantext/API/Node/Contact.hs
View file @ beb78a05
...@@ -22,11 +22,7 @@ module Gargantext.API.Node.Contact ...@@ -22,11 +22,7 @@ module Gargantext.API.Node.Contact
import Conduit ( yield ) import Conduit ( yield )
import Data.Aeson import Data.Aeson
import Data.Either (Either(Right))
import Data.Maybe (Maybe(..))
import Data.Swagger ( ToSchema ) import Data.Swagger ( ToSchema )
import Data.Text (Text)
import GHC.Generics (Generic)
import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(AuthenticatedUser) ) import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(AuthenticatedUser) )
import Gargantext.API.Admin.EnvTypes (Env, GargJob(..)) import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs) import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
...@@ -42,12 +38,13 @@ import Gargantext.Database.Action.Flow.Types (FlowCmdM) ...@@ -42,12 +38,13 @@ import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact, hyperdataContact ) import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact, hyperdataContact )
import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataAnnuaire(..) ) import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataAnnuaire(..) )
import Gargantext.Database.Admin.Types.Node ( CorpusId, NodeId ) import Gargantext.Database.Admin.Types.Node ( CorpusId, NodeId )
import Gargantext.Prelude (($), {-printDebug,-}) import Gargantext.Prelude (($), Generic, Maybe(..), Text)
import Gargantext.Utils.Aeson qualified as GUA import Gargantext.Utils.Aeson qualified as GUA
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..)) import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Servant import Servant
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary ( Arbitrary(arbitrary) ) import Test.QuickCheck.Arbitrary ( Arbitrary(arbitrary) )
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusIds))
------------------------------------------------------------------------ ------------------------------------------------------------------------
type API = "contact" :> Summary "Contact endpoint" type API = "contact" :> Summary "Contact endpoint"
...@@ -85,7 +82,7 @@ addContact :: (HasSettings env, FlowCmdM env err m, MonadJobStatus m) ...@@ -85,7 +82,7 @@ addContact :: (HasSettings env, FlowCmdM env err m, MonadJobStatus m)
addContact u nId (AddContactParams fn ln) jobHandle = do addContact u nId (AddContactParams fn ln) jobHandle = do
markStarted 2 jobHandle markStarted 2 jobHandle
_ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) Nothing (1, yield $ hyperdataContact fn ln) jobHandle _ <- flow (Nothing :: Maybe HyperdataAnnuaire) (MkCorpusUserNormalCorpusIds u [nId]) (Multi EN) Nothing (1, yield $ hyperdataContact fn ln) jobHandle
markComplete jobHandle markComplete jobHandle
addContact _uId _nId _p jobHandle = do addContact _uId _nId _p jobHandle = do
......
src/Gargantext/API/Node/Corpus/New.hs
View file @ beb78a05
...@@ -56,6 +56,7 @@ import Gargantext.Database.GargDB qualified as GargDB ...@@ -56,6 +56,7 @@ import Gargantext.Database.GargDB qualified as GargDB
import Gargantext.Database.Prelude (hasConfig) import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Database.Query.Table.Node (getNodeWith, getOrMkList) import Gargantext.Database.Query.Table.Node (getNodeWith, getOrMkList)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusIds))
import Gargantext.Database.Schema.Node (node_hyperdata) import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_max_docs_parsers) import Gargantext.Prelude.Config (gc_max_docs_parsers)
...@@ -335,8 +336,7 @@ addToCorpusWithForm user cid nwf jobHandle = do ...@@ -335,8 +336,7 @@ addToCorpusWithForm user cid nwf jobHandle = do
-- TODO granularity of the logStatus -- TODO granularity of the logStatus
-- printDebug "flowCorpus with (corpus_id, lang)" (cid, l) -- printDebug "flowCorpus with (corpus_id, lang)" (cid, l)
_cid' <- flowCorpus user _cid' <- flowCorpus (MkCorpusUserNormalCorpusIds user [cid])
(Right [cid])
(Multi l) (Multi l)
(Just (nwf ^. wf_selection)) (Just (nwf ^. wf_selection))
--(Just $ fromIntegral $ length docs, docsC') --(Just $ fromIntegral $ length docs, docsC')
......
src/Gargantext/API/Node/Corpus/Searx.hs
View file @ beb78a05
...@@ -35,7 +35,6 @@ import Gargantext.Core.Utils.Prefix (unPrefix) ...@@ -35,7 +35,6 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Action.Flow (addDocumentsToHyperCorpus) --, DataText(..)) import Gargantext.Database.Action.Flow (addDocumentsToHyperCorpus) --, DataText(..))
import Gargantext.Database.Action.Flow.List (flowList_DbRepo) import Gargantext.Database.Action.Flow.List (flowList_DbRepo)
import Gargantext.Database.Action.User (getUserId) import Gargantext.Database.Action.User (getUserId)
import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus) import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus)
import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..)) import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
import Gargantext.Database.Admin.Types.Node (CorpusId, ListId, NodeType(NodeTexts)) import Gargantext.Database.Admin.Types.Node (CorpusId, ListId, NodeType(NodeTexts))
...@@ -43,7 +42,7 @@ import Gargantext.Database.Prelude (hasConfig) ...@@ -43,7 +42,7 @@ import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Database.Query.Table.Node (getOrMkList, insertDefaultNodeIfNotExists) import Gargantext.Database.Query.Table.Node (getOrMkList, insertDefaultNodeIfNotExists)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Tree.Error (HasTreeError) import Gargantext.Database.Query.Tree.Error (HasTreeError)
import Gargantext.Database.Query.Tree.Root (getOrMk_RootWithCorpus) import Gargantext.Database.Query.Tree.Root (getOrMkRootWithCorpus, MkCorpusUser (MkCorpusUserMaster))
import Gargantext.Prelude hiding (All) import Gargantext.Prelude hiding (All)
import Gargantext.Prelude.Config import Gargantext.Prelude.Config
import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..)) import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
...@@ -148,7 +147,7 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) = ...@@ -148,7 +147,7 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) =
let mCorpus = Nothing :: Maybe HyperdataCorpus let mCorpus = Nothing :: Maybe HyperdataCorpus
void $ addDocumentsToHyperCorpus server mCorpus (Multi l) cId docs' void $ addDocumentsToHyperCorpus server mCorpus (Multi l) cId docs'
(_masterUserId, _masterRootId, masterCorpusId) (_masterUserId, _masterRootId, masterCorpusId)
<- getOrMk_RootWithCorpus (UserName userMaster) (Left "") mCorpus <- getOrMkRootWithCorpus MkCorpusUserMaster mCorpus
let gp = GroupWithPosTag l server HashMap.empty let gp = GroupWithPosTag l server HashMap.empty
-- gp = case l of -- gp = case l of
-- FR -> GroupWithPosTag l Spacy HashMap.empty -- FR -> GroupWithPosTag l Spacy HashMap.empty
......
src/Gargantext/Database/Action/Flow.hs
View file @ beb78a05
...@@ -41,7 +41,7 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list) ...@@ -41,7 +41,7 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
, reIndexWith , reIndexWith
, getOrMkRoot , getOrMkRoot
, getOrMk_RootWithCorpus , getOrMkRootWithCorpus
, TermType(..) , TermType(..)
, DataOrigin(..) , DataOrigin(..)
, allDataOrigins , allDataOrigins
...@@ -78,7 +78,7 @@ import Gargantext.Core.Text.Terms ...@@ -78,7 +78,7 @@ import Gargantext.Core.Text.Terms
import Gargantext.Core.Text.Terms.Mono.Stem (stem, StemmingAlgorithm(..)) import Gargantext.Core.Text.Terms.Mono.Stem (stem, StemmingAlgorithm(..))
import Gargantext.Core.Types (HasValidationError, TermsCount) import Gargantext.Core.Types (HasValidationError, TermsCount)
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Main ( CorpusName, ListType(MapTerm) ) import Gargantext.Core.Types.Main ( ListType(MapTerm) )
import Gargantext.Core.Types.Query (Limit) import Gargantext.Core.Types.Query (Limit)
import Gargantext.Database.Action.Flow.Extract () -- ExtractNgramsT instances import Gargantext.Database.Action.Flow.Extract () -- ExtractNgramsT instances
import Gargantext.Database.Action.Flow.List ( flowList_DbRepo, toNodeNgramsW' ) import Gargantext.Database.Action.Flow.List ( flowList_DbRepo, toNodeNgramsW' )
...@@ -86,7 +86,6 @@ import Gargantext.Database.Action.Flow.Types ( do_api, DataOrigin(..), DataText( ...@@ -86,7 +86,6 @@ import Gargantext.Database.Action.Flow.Types ( do_api, DataOrigin(..), DataText(
import Gargantext.Database.Action.Flow.Utils (docNgrams, documentIdWithNgrams, insertDocNgrams, insertDocs, mapNodeIdNgrams) import Gargantext.Database.Action.Flow.Utils (docNgrams, documentIdWithNgrams, insertDocNgrams, insertDocs, mapNodeIdNgrams)
import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContextScore) import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContextScore)
import Gargantext.Database.Action.Search (searchDocInDatabase) import Gargantext.Database.Action.Search (searchDocInDatabase)
import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact ) import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact )
import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataAnnuaire, HyperdataCorpus(_hc_lang) ) import Gargantext.Database.Admin.Types.Hyperdata.Corpus ( HyperdataAnnuaire, HyperdataCorpus(_hc_lang) )
import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(toHyperdataDocument) ) import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(toHyperdataDocument) )
...@@ -99,7 +98,7 @@ import Gargantext.Database.Query.Table.Node.Document.Insert ( ToNode(toNode) ) - ...@@ -99,7 +98,7 @@ import Gargantext.Database.Query.Table.Node.Document.Insert ( ToNode(toNode) ) -
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..)) import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Table.NodeContext (selectDocNodes) import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
import Gargantext.Database.Query.Table.NodeNgrams (listInsertDb , getCgramsId) import Gargantext.Database.Query.Table.NodeNgrams (listInsertDb , getCgramsId)
import Gargantext.Database.Query.Tree.Root (getOrMkRoot, getOrMk_RootWithCorpus) import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..), getOrMkRoot, getOrMkRootWithCorpus, userFromMkCorpusUser)
import Gargantext.Database.Schema.Ngrams ( indexNgrams, text2ngrams ) import Gargantext.Database.Schema.Ngrams ( indexNgrams, text2ngrams )
import Gargantext.Database.Schema.Node (node_hyperdata) import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude hiding (to) import Gargantext.Prelude hiding (to)
...@@ -140,10 +139,7 @@ getDataText (ExternalOrigin api) la q mPubmedAPIKey mAuthKey li = do ...@@ -140,10 +139,7 @@ getDataText (ExternalOrigin api) la q mPubmedAPIKey mAuthKey li = do
eRes <- liftBase $ API.get api (_tt_lang la) q mPubmedAPIKey mAuthKey (_gc_epo_api_url cfg) li eRes <- liftBase $ API.get api (_tt_lang la) q mPubmedAPIKey mAuthKey (_gc_epo_api_url cfg) li
pure $ DataNew <$> eRes pure $ DataNew <$> eRes
getDataText (InternalOrigin _) la q _ _ _li = do getDataText (InternalOrigin _) la q _ _ _li = do
(_masterUserId, _masterRootId, cId) <- getOrMk_RootWithCorpus (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus MkCorpusUserMaster (Nothing :: Maybe HyperdataCorpus)
(UserName userMaster)
(Left "")
(Nothing :: Maybe HyperdataCorpus)
ids <- map fst <$> searchDocInDatabase cId (stem (_tt_lang la) GargPorterAlgorithm $ API.getRawQuery q) ids <- map fst <$> searchDocInDatabase cId (stem (_tt_lang la) GargPorterAlgorithm $ API.getRawQuery q)
pure $ Right $ DataOld ids pure $ Right $ DataOld ids
...@@ -179,7 +175,7 @@ flowDataText :: forall env err m. ...@@ -179,7 +175,7 @@ flowDataText :: forall env err m.
-> m CorpusId -> m CorpusId
flowDataText u (DataOld ids) tt cid mfslw _ = do flowDataText u (DataOld ids) tt cid mfslw _ = do
$(logLocM) DEBUG $ T.pack $ "Found " <> show (length ids) <> " old node IDs" $(logLocM) DEBUG $ T.pack $ "Found " <> show (length ids) <> " old node IDs"
(_userId, userCorpusId, listId) <- createNodes u (Right [cid]) corpusType (_userId, userCorpusId, listId) <- createNodes (MkCorpusUserNormalCorpusIds u [cid]) corpusType
_ <- Doc.add userCorpusId (map nodeId2ContextId ids) _ <- Doc.add userCorpusId (map nodeId2ContextId ids)
flowCorpusUser (_tt_lang tt) u userCorpusId listId corpusType mfslw flowCorpusUser (_tt_lang tt) u userCorpusId listId corpusType mfslw
where where
...@@ -187,7 +183,7 @@ flowDataText u (DataOld ids) tt cid mfslw _ = do ...@@ -187,7 +183,7 @@ flowDataText u (DataOld ids) tt cid mfslw _ = do
flowDataText u (DataNew (mLen, txtC)) tt cid mfslw jobHandle = do flowDataText u (DataNew (mLen, txtC)) tt cid mfslw jobHandle = do
$(logLocM) DEBUG $ T.pack $ "Found " <> show mLen <> " new documents to process" $(logLocM) DEBUG $ T.pack $ "Found " <> show mLen <> " new documents to process"
for_ (mLen <&> fromInteger) (`addMoreSteps` jobHandle) for_ (mLen <&> fromInteger) (`addMoreSteps` jobHandle)
flowCorpus u (Right [cid]) tt mfslw (fromMaybe 0 mLen, transPipe liftBase txtC) jobHandle flowCorpus (MkCorpusUserNormalCorpusIds u [cid]) tt mfslw (fromMaybe 0 mLen, transPipe liftBase txtC) jobHandle
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- TODO use proxy -- TODO use proxy
...@@ -198,16 +194,15 @@ flowAnnuaire :: ( DbCmd' env err m ...@@ -198,16 +194,15 @@ flowAnnuaire :: ( DbCmd' env err m
, HasTreeError err , HasTreeError err
, HasValidationError err , HasValidationError err
, MonadJobStatus m ) , MonadJobStatus m )
=> User => MkCorpusUser
-> Either CorpusName [CorpusId]
-> TermType Lang -> TermType Lang
-> FilePath -> FilePath
-> JobHandle m -> JobHandle m
-> m AnnuaireId -> m AnnuaireId
flowAnnuaire u n l filePath jobHandle = do flowAnnuaire mkCorpusUser l filePath jobHandle = do
-- TODO Conduit for file -- TODO Conduit for file
docs <- liftBase $ (readFile_Annuaire filePath :: IO [HyperdataContact]) docs <- liftBase (readFile_Annuaire filePath :: IO [HyperdataContact])
flow (Nothing :: Maybe HyperdataAnnuaire) u n l Nothing (fromIntegral $ length docs, yieldMany docs) jobHandle flow (Nothing :: Maybe HyperdataAnnuaire) mkCorpusUser l Nothing (fromIntegral $ length docs, yieldMany docs) jobHandle
------------------------------------------------------------------------ ------------------------------------------------------------------------
flowCorpusFile :: ( DbCmd' env err m flowCorpusFile :: ( DbCmd' env err m
...@@ -217,8 +212,7 @@ flowCorpusFile :: ( DbCmd' env err m ...@@ -217,8 +212,7 @@ flowCorpusFile :: ( DbCmd' env err m
, HasTreeError err , HasTreeError err
, HasValidationError err , HasValidationError err
, MonadJobStatus m ) , MonadJobStatus m )
=> User => MkCorpusUser
-> Either CorpusName [CorpusId]
-> Limit -- Limit the number of docs (for dev purpose) -> Limit -- Limit the number of docs (for dev purpose)
-> TermType Lang -> TermType Lang
-> FileType -> FileType
...@@ -227,11 +221,11 @@ flowCorpusFile :: ( DbCmd' env err m ...@@ -227,11 +221,11 @@ flowCorpusFile :: ( DbCmd' env err m
-> Maybe FlowSocialListWith -> Maybe FlowSocialListWith
-> JobHandle m -> JobHandle m
-> m CorpusId -> m CorpusId
flowCorpusFile u n _l la ft ff fp mfslw jobHandle = do flowCorpusFile mkCorpusUser _l la ft ff fp mfslw jobHandle = do
eParsed <- liftBase $ parseFile ft ff fp eParsed <- liftBase $ parseFile ft ff fp
case eParsed of case eParsed of
Right parsed -> do Right parsed -> do
flowCorpus u n la mfslw (fromIntegral $ length parsed, yieldMany parsed .| mapC toHyperdataDocument) jobHandle flowCorpus mkCorpusUser la mfslw (fromIntegral $ length parsed, yieldMany parsed .| mapC toHyperdataDocument) jobHandle
--let docs = splitEvery 500 $ take l parsed --let docs = splitEvery 500 $ take l parsed
--flowCorpus u n la mfslw (yieldMany $ map (map toHyperdataDocument) docs) logStatus --flowCorpus u n la mfslw (yieldMany $ map (map toHyperdataDocument) docs) logStatus
Left e -> panicTrace $ "Error: " <> e Left e -> panicTrace $ "Error: " <> e
...@@ -247,8 +241,7 @@ flowCorpus :: ( DbCmd' env err m ...@@ -247,8 +241,7 @@ flowCorpus :: ( DbCmd' env err m
, HasValidationError err , HasValidationError err
, FlowCorpus a , FlowCorpus a
, MonadJobStatus m ) , MonadJobStatus m )
=> User => MkCorpusUser
-> Either CorpusName [CorpusId]
-> TermType Lang -> TermType Lang
-> Maybe FlowSocialListWith -> Maybe FlowSocialListWith
-> (Integer, ConduitT () a m ()) -> (Integer, ConduitT () a m ())
...@@ -269,15 +262,14 @@ flow :: forall env err m a c. ...@@ -269,15 +262,14 @@ flow :: forall env err m a c.
, MonadJobStatus m , MonadJobStatus m
) )
=> Maybe c => Maybe c
-> User -> MkCorpusUser
-> Either CorpusName [CorpusId]
-> TermType Lang -> TermType Lang
-> Maybe FlowSocialListWith -> Maybe FlowSocialListWith
-> (Integer, ConduitT () a m ()) -> (Integer, ConduitT () a m ())
-> JobHandle m -> JobHandle m
-> m CorpusId -> m CorpusId
flow c u cn la mfslw (count, docsC) jobHandle = do flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do
(_userId, userCorpusId, listId) <- createNodes u cn 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) nlpServer <- view $ nlpServerGet (_tt_lang la)
runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC
...@@ -285,6 +277,8 @@ flow c u cn la mfslw (count, docsC) jobHandle = do ...@@ -285,6 +277,8 @@ flow c u cn la mfslw (count, docsC) jobHandle = do
.| mapM_C (addDocumentsWithProgress nlpServer userCorpusId) .| mapM_C (addDocumentsWithProgress nlpServer userCorpusId)
.| sinkNull .| sinkNull
let u = userFromMkCorpusUser mkCorpusUser
$(logLocM) DEBUG "Calling flowCorpusUser" $(logLocM) DEBUG "Calling flowCorpusUser"
flowCorpusUser (la ^. tt_lang) u userCorpusId listId c mfslw flowCorpusUser (la ^. tt_lang) u userCorpusId listId c mfslw
...@@ -318,13 +312,12 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do ...@@ -318,13 +312,12 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do
createNodes :: ( DbCmd' env err m, HasNodeError err createNodes :: ( DbCmd' env err m, HasNodeError err
, MkCorpus c , MkCorpus c
) )
=> User => MkCorpusUser
-> Either CorpusName [CorpusId]
-> Maybe c -> Maybe c
-> m (UserId, CorpusId, ListId) -> m (UserId, CorpusId, ListId)
createNodes user corpusName ctype = do createNodes mkCorpusUser ctype = do
-- User Flow -- User Flow
(userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus user corpusName ctype (userId, _rootId, userCorpusId) <- getOrMkRootWithCorpus mkCorpusUser ctype
-- NodeTexts is first -- NodeTexts is first
_tId <- insertDefaultNodeIfNotExists NodeTexts userCorpusId userId _tId <- insertDefaultNodeIfNotExists NodeTexts userCorpusId userId
-- printDebug "NodeTexts: " tId -- printDebug "NodeTexts: " tId
...@@ -386,7 +379,7 @@ buildSocialList _l _user _userCorpusId _listId _ctype (Just (NoList _)) = pure ( ...@@ -386,7 +379,7 @@ buildSocialList _l _user _userCorpusId _listId _ctype (Just (NoList _)) = pure (
buildSocialList l user userCorpusId listId ctype mfslw = do buildSocialList l user userCorpusId listId ctype mfslw = do
-- User List Flow -- User List Flow
(masterUserId, _masterRootId, masterCorpusId) (masterUserId, _masterRootId, masterCorpusId)
<- getOrMk_RootWithCorpus (UserName userMaster) (Left "") ctype <- getOrMkRootWithCorpus MkCorpusUserMaster ctype
nlpServer <- view (nlpServerGet l) nlpServer <- view (nlpServerGet l)
--let gp = (GroupParams l 2 3 (StopSize 3)) --let gp = (GroupParams l 2 3 (StopSize 3))
...@@ -416,7 +409,7 @@ insertMasterDocs :: ( DbCmd' env err m ...@@ -416,7 +409,7 @@ insertMasterDocs :: ( DbCmd' env err m
-> [a] -> [a]
-> m [DocId] -> m [DocId]
insertMasterDocs ncs c lang hs = do insertMasterDocs ncs c lang hs = do
(masterUserId, _, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left corpusMasterName) c (masterUserId, _, masterCorpusId) <- getOrMkRootWithCorpus MkCorpusUserMaster c
(ids', documentsWithId) <- insertDocs masterUserId masterCorpusId (map (toNode masterUserId Nothing) hs ) (ids', documentsWithId) <- insertDocs masterUserId masterCorpusId (map (toNode masterUserId Nothing) hs )
_ <- Doc.add masterCorpusId ids' _ <- Doc.add masterCorpusId ids'
-- TODO -- TODO
......
src/Gargantext/Database/Query/Tree/Root.hs
View file @ beb78a05
...@@ -14,20 +14,19 @@ module Gargantext.Database.Query.Tree.Root ...@@ -14,20 +14,19 @@ module Gargantext.Database.Query.Tree.Root
where where
import Control.Arrow (returnA) import Control.Arrow (returnA)
import Gargantext.Core import Gargantext.Core (HasDBid(..))
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Main (CorpusName) import Gargantext.Core.Types.Main (CorpusName)
import Gargantext.Database.Action.Node import Gargantext.Database.Action.Node ( mkNodeWithParent )
import Gargantext.Database.Action.User (getUserId, getUsername) import Gargantext.Database.Action.User (getUserId, getUsername)
import Gargantext.Database.Admin.Config import Gargantext.Database.Admin.Config ( corpusMasterName, userMaster )
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser) import Gargantext.Database.Admin.Types.Hyperdata.User ( HyperdataUser )
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (runOpaQuery, DBCmd) import Gargantext.Database.Prelude (runOpaQuery, DBCmd)
import Gargantext.Database.Query.Table.Node import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..)) import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead) import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead, queryNodeTable)
import Gargantext.Database.Schema.Node (queryNodeTable)
import Gargantext.Prelude import Gargantext.Prelude
import Opaleye (restrict, (.==), Select) import Opaleye (restrict, (.==), Select)
import Opaleye.SqlTypes (sqlStrictText, sqlInt4) import Opaleye.SqlTypes (sqlStrictText, sqlInt4)
...@@ -61,30 +60,62 @@ getOrMkRoot user = do ...@@ -61,30 +60,62 @@ getOrMkRoot user = do
pure (userId, rootId) pure (userId, rootId)
getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a) -- | Datatype for the `getOrMkRootWithCorpus`.
=> User -- There are only 3 possibilities:
-> Either CorpusName [CorpusId] -- - User is userMaster and then there is no corpus name
-- - User is a normal user and then we pass corpus name
-- - User is a normal user and then we pass corpus ids
data MkCorpusUser =
MkCorpusUserMaster
| MkCorpusUserNormalCorpusName User CorpusName
| MkCorpusUserNormalCorpusIds User [CorpusId]
deriving (Eq, Show)
userFromMkCorpusUser :: MkCorpusUser -> User
userFromMkCorpusUser MkCorpusUserMaster = UserName userMaster
userFromMkCorpusUser (MkCorpusUserNormalCorpusIds u _cids) = u
userFromMkCorpusUser (MkCorpusUserNormalCorpusName u _cname) = u
getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
=> MkCorpusUser
-> Maybe a -> Maybe a
-> DBCmd err (UserId, RootId, CorpusId) -> DBCmd err (UserId, RootId, CorpusId)
getOrMk_RootWithCorpus user cName c = do getOrMkRootWithCorpus MkCorpusUserMaster c = do
(userId, rootId) <- getOrMkRoot (UserName userMaster)
corpusId'' <- do
ns <- getCorporaWithParentId rootId
pure $ map _node_id ns
case corpusId'' of
[] -> mkCorpus corpusMasterName c rootId userId
cIds -> do
corpusId <- maybe (nodeError NoCorpusFound) pure (head cIds)
pure (userId, rootId, corpusId)
getOrMkRootWithCorpus (MkCorpusUserNormalCorpusName user cName) c = do
(userId, rootId) <- getOrMkRoot user
mkCorpus cName c rootId userId
getOrMkRootWithCorpus (MkCorpusUserNormalCorpusIds user []) c = do
getOrMkRootWithCorpus (MkCorpusUserNormalCorpusName user "Default") c
getOrMkRootWithCorpus (MkCorpusUserNormalCorpusIds user cIds) _c = do
(userId, rootId) <- getOrMkRoot user (userId, rootId) <- getOrMkRoot user
corpusId'' <- if user == UserName userMaster corpusId <- maybe (nodeError NoCorpusFound) pure (head cIds)
then do pure (userId, rootId, corpusId)
ns <- getCorporaWithParentId rootId
pure $ map _node_id ns
else -- | Helper function for `getOrMkRootWithCorpus`.
pure $ fromRight [] cName mkCorpus :: (HasNodeError err, MkCorpus a)
=> CorpusName
corpusId' <- if corpusId'' /= [] -> Maybe a
then pure corpusId'' -> RootId
else do -> UserId
c' <- mk (Just $ fromLeft "Default" cName) c rootId userId -> DBCmd err (UserId, RootId, CorpusId)
_tId <- case head c' of mkCorpus cName c rootId userId = do
Nothing -> errorWith "[G.D.Q.T.Root.getOrMk...] mk Corpus failed" c' <- mk (Just cName) c rootId userId
Just c'' -> insertDefaultNode NodeTexts c'' userId _tId <- case head c' of
pure c' Nothing -> errorWith "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
Just c'' -> insertDefaultNode NodeTexts c'' userId
corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
corpusId <- maybe (nodeError NoCorpusFound) pure (head c')
pure (userId, rootId, corpusId) pure (userId, rootId, corpusId)
...@@ -118,20 +149,20 @@ selectRoot :: User -> Select NodeRead ...@@ -118,20 +149,20 @@ selectRoot :: User -> Select NodeRead
selectRoot (UserName username) = proc () -> do selectRoot (UserName username) = proc () -> do
row <- queryNodeTable -< () row <- queryNodeTable -< ()
users <- queryUserTable -< () users <- queryUserTable -< ()
restrict -< _node_typename row .== (sqlInt4 $ toDBid NodeUser) restrict -< _node_typename row .== sqlInt4 (toDBid NodeUser)
restrict -< user_username users .== (sqlStrictText username) restrict -< user_username users .== sqlStrictText username
restrict -< _node_user_id row .== (user_id users) restrict -< _node_user_id row .== user_id users
returnA -< row returnA -< row
selectRoot (UserDBId uid) = proc () -> do selectRoot (UserDBId uid) = proc () -> do
row <- queryNodeTable -< () row <- queryNodeTable -< ()
restrict -< _node_typename row .== (sqlInt4 $ toDBid NodeUser) restrict -< _node_typename row .== sqlInt4 (toDBid NodeUser)
restrict -< _node_user_id row .== (sqlInt4 $ _UserId uid) restrict -< _node_user_id row .== sqlInt4 (_UserId uid)
returnA -< row returnA -< row
selectRoot (RootId nid) = selectRoot (RootId nid) =
proc () -> do proc () -> do
row <- queryNodeTable -< () row <- queryNodeTable -< ()
restrict -< _node_typename row .== (sqlInt4 $ toDBid NodeUser) restrict -< _node_typename row .== sqlInt4 (toDBid NodeUser)
restrict -< _node_id row .== (pgNodeId nid) restrict -< _node_id row .== pgNodeId nid
returnA -< row returnA -< row
test/Test/API/Setup.hs
View file @ beb78a05
...@@ -3,6 +3,7 @@ ...@@ -3,6 +3,7 @@
module Test.API.Setup where module Test.API.Setup where
-- import Gargantext.Prelude (printDebug)
import Control.Lens import Control.Lens
import Control.Monad.Reader import Control.Monad.Reader
import Gargantext.API (makeApp) import Gargantext.API (makeApp)
...@@ -21,24 +22,24 @@ import Gargantext.Database.Admin.Trigger.Init ...@@ -21,24 +22,24 @@ import Gargantext.Database.Admin.Trigger.Init
import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Prelude import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (getOrMkList) import Gargantext.Database.Query.Table.Node (getOrMkList)
-- import Gargantext.Prelude (printDebug) import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))
import Gargantext.Prelude.Config import Gargantext.Prelude.Config
import Gargantext.Prelude.Mail qualified as Mail
import Gargantext.Prelude.NLP qualified as NLP
import Gargantext.System.Logging import Gargantext.System.Logging
import Gargantext.Utils.Jobs qualified as Jobs
import Gargantext.Utils.Jobs.Monad qualified as Jobs
import Gargantext.Utils.Jobs.Queue qualified as Jobs
import Gargantext.Utils.Jobs.Settings qualified as Jobs
import Network.HTTP.Client.TLS (newTlsManager) import Network.HTTP.Client.TLS (newTlsManager)
import Network.Wai (Application) import Network.Wai (Application)
import Network.Wai.Handler.Warp qualified as Warp
import Prelude import Prelude
import Servant.Auth.Client () import Servant.Auth.Client ()
import Servant.Client import Servant.Client
import Servant.Job.Async qualified as ServantAsync
import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo) import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo)
import Test.Database.Types import Test.Database.Types
import qualified Gargantext.Prelude.Mail as Mail
import qualified Gargantext.Prelude.NLP as NLP
import qualified Gargantext.Utils.Jobs as Jobs
import qualified Gargantext.Utils.Jobs.Monad as Jobs
import qualified Gargantext.Utils.Jobs.Queue as Jobs
import qualified Gargantext.Utils.Jobs.Settings as Jobs
import qualified Network.Wai.Handler.Warp as Warp
import qualified Servant.Job.Async as ServantAsync
newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env
...@@ -97,9 +98,7 @@ setupEnvironment env = flip runReaderT env $ runTestMonad $ do ...@@ -97,9 +98,7 @@ setupEnvironment env = flip runReaderT env $ runTestMonad $ do
void $ initFirstTriggers "secret_key" void $ initFirstTriggers "secret_key"
void $ new_user $ mkNewUser (userMaster <> "@cnrs.com") (GargPassword "secret_key") void $ new_user $ mkNewUser (userMaster <> "@cnrs.com") (GargPassword "secret_key")
(masterUserId, _masterRootId, masterCorpusId) (masterUserId, _masterRootId, masterCorpusId)
<- getOrMk_RootWithCorpus (UserName userMaster) <- getOrMkRootWithCorpus MkCorpusUserMaster (Nothing :: Maybe HyperdataCorpus)
(Left corpusMasterName)
(Nothing :: Maybe HyperdataCorpus)
masterListId <- getOrMkList masterCorpusId masterUserId masterListId <- getOrMkList masterCorpusId masterUserId
-- printDebug "[setupEnvironment] masterListId: " masterListId -- printDebug "[setupEnvironment] masterListId: " masterListId
void $ initLastTriggers masterListId void $ initLastTriggers masterListId
......
test/Test/Ngrams/Query.hs
View file @ beb78a05
...@@ -36,7 +36,7 @@ mockFlatCorpus = Versioned 0 $ Map.fromList [ ...@@ -36,7 +36,7 @@ mockFlatCorpus = Versioned 0 $ Map.fromList [
mockQueryFn :: Maybe T.Text -> NgramsTerm -> Bool mockQueryFn :: Maybe T.Text -> NgramsTerm -> Bool
mockQueryFn searchQuery (NgramsTerm nt) = mockQueryFn searchQuery (NgramsTerm nt) =
maybe (const True) T.isInfixOf (T.toLower <$> searchQuery) (T.toLower nt) maybe (const True) (T.isInfixOf . T.toLower) searchQuery (T.toLower nt)
unitTests :: TestTree unitTests :: TestTree
unitTests = testGroup "Query tests" unitTests = testGroup "Query tests"
......
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