[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.

bin/gargantext-import/Main.hs

@@ -15,22 +15,22 @@ Import a corpus binary.
 
 module Main where
 
-import Data.Either
-import qualified Data.Text as Text
-
-import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
+import Data.Text qualified as Text
 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.Core (Lang(..))
+import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..))
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Types.Query (Limit)
 import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..))
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Node (CorpusId)
+import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusName))
 import Gargantext.Prelude
-import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..))
-import Gargantext.Utils.Jobs (MonadJobStatus, JobHandle)
+import Gargantext.Utils.Jobs.Monad ( MonadJobStatus, JobHandle )
+
 
 main :: IO ()
 main = do
@@ -46,13 +46,14 @@ main = do
       Nothing -> panicTrace $ "Cannot read limit: " <> (Text.pack limit)
       Just l  -> l
     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 = 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 = 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

bin/gargantext-init/Main.hs

@@ -15,21 +15,21 @@ Import a corpus binary.
 
 module Main where
 
+import Data.List.NonEmpty qualified as NE
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Errors.Types
 import Gargantext.API.Node () -- instances only
 import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..))
-import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMk_RootWithCorpus)
-import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
+import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMkRootWithCorpus)
 import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (Cmd, DBCmd)
 import Gargantext.Database.Query.Table.Node (getOrMkList)
 import Gargantext.Database.Query.Table.User (insertNewUsers, )
+import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserMaster))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..), readConfig)
-import qualified Data.List.NonEmpty as NE
 
 
 main :: IO ()
@@ -63,8 +63,7 @@ main = do
     initMaster :: Cmd BackendInternalError (UserId, RootId, CorpusId, ListId)
     initMaster = do
       (masterUserId, masterRootId, masterCorpusId)
-                  <- getOrMk_RootWithCorpus (UserName userMaster)
-                                            (Left corpusMasterName)
+                  <- getOrMkRootWithCorpus MkCorpusUserMaster
                                             (Nothing :: Maybe HyperdataCorpus)
       masterListId <- getOrMkList masterCorpusId masterUserId
       _triggers    <- initLastTriggers masterListId

src/Gargantext/API/Node/Contact.hs

@@ -22,11 +22,7 @@ module Gargantext.API.Node.Contact
 
 import Conduit ( yield )
 import Data.Aeson
-import Data.Either (Either(Right))
-import Data.Maybe (Maybe(..))
 import Data.Swagger ( ToSchema )
-import Data.Text (Text)
-import GHC.Generics (Generic)
 import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(AuthenticatedUser) )
 import Gargantext.API.Admin.EnvTypes (Env, GargJob(..))
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
@@ -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.Corpus ( HyperdataAnnuaire(..) )
 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.Jobs (serveJobsAPI, MonadJobStatus(..))
 import Servant
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary ( Arbitrary(arbitrary) )
+import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpusIds))
 
 ------------------------------------------------------------------------
 type API = "contact" :> Summary "Contact endpoint"
@@ -85,7 +82,7 @@ addContact :: (HasSettings env, FlowCmdM env err m, MonadJobStatus m)
 addContact u nId (AddContactParams fn ln) jobHandle = do
 
   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
 addContact _uId _nId _p jobHandle = do

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

@@ -56,6 +56,7 @@ import Gargantext.Database.GargDB qualified as GargDB
 import Gargantext.Database.Prelude (hasConfig)
 import Gargantext.Database.Query.Table.Node (getNodeWith, getOrMkList)
 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.Prelude
 import Gargantext.Prelude.Config (gc_max_docs_parsers)
@@ -335,8 +336,7 @@ addToCorpusWithForm user cid nwf jobHandle = do
       -- TODO granularity of the logStatus
       -- printDebug "flowCorpus with (corpus_id, lang)" (cid, l)
 
-      _cid' <- flowCorpus user
-                          (Right [cid])
+      _cid' <- flowCorpus (MkCorpusUserNormalCorpusIds user [cid])
                           (Multi l)
                           (Just (nwf ^. wf_selection))
                           --(Just $ fromIntegral $ length docs, docsC')

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

@@ -35,7 +35,6 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Action.Flow (addDocumentsToHyperCorpus) --, DataText(..))
 import Gargantext.Database.Action.Flow.List (flowList_DbRepo)
 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.Document (HyperdataDocument(..))
 import Gargantext.Database.Admin.Types.Node (CorpusId, ListId, NodeType(NodeTexts))
@@ -43,7 +42,7 @@ import Gargantext.Database.Prelude (hasConfig)
 import Gargantext.Database.Query.Table.Node (getOrMkList, insertDefaultNodeIfNotExists)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 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.Config
 import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
@@ -148,7 +147,7 @@ insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) =
   let mCorpus = Nothing :: Maybe HyperdataCorpus
   void $ addDocumentsToHyperCorpus server mCorpus (Multi l) cId docs'
   (_masterUserId, _masterRootId, masterCorpusId)
-    <- getOrMk_RootWithCorpus (UserName userMaster) (Left "") mCorpus
+    <- getOrMkRootWithCorpus MkCorpusUserMaster mCorpus
   let gp = GroupWithPosTag l server HashMap.empty
     -- gp = case l of
     --   FR -> GroupWithPosTag l Spacy HashMap.empty

src/Gargantext/Database/Action/Flow.hs

@@ -41,7 +41,7 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
   , reIndexWith
 
   , getOrMkRoot
-  , getOrMk_RootWithCorpus
+  , getOrMkRootWithCorpus
   , TermType(..)
   , DataOrigin(..)
   , allDataOrigins
@@ -78,7 +78,7 @@ import Gargantext.Core.Text.Terms
 import Gargantext.Core.Text.Terms.Mono.Stem (stem, StemmingAlgorithm(..))
 import Gargantext.Core.Types (HasValidationError, TermsCount)
 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.Database.Action.Flow.Extract ()  -- ExtractNgramsT instances
 import Gargantext.Database.Action.Flow.List ( flowList_DbRepo, toNodeNgramsW' )
@@ -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.Metrics (updateNgramsOccurrences, updateContextScore)
 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.Corpus ( HyperdataAnnuaire, HyperdataCorpus(_hc_lang) )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( ToHyperdataDocument(toHyperdataDocument) )
@@ -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.NodeContext (selectDocNodes)
 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.Node (node_hyperdata)
 import Gargantext.Prelude hiding (to)
@@ -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
   pure $ DataNew <$> eRes
 getDataText (InternalOrigin _) la q _ _ _li = do
-  (_masterUserId, _masterRootId, cId) <- getOrMk_RootWithCorpus
-                                           (UserName userMaster)
-                                           (Left "")
-                                           (Nothing :: Maybe HyperdataCorpus)
+  (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus MkCorpusUserMaster (Nothing :: Maybe HyperdataCorpus)
   ids <-  map fst <$> searchDocInDatabase cId (stem (_tt_lang la) GargPorterAlgorithm $ API.getRawQuery q)
   pure $ Right $ DataOld ids
 
@@ -179,7 +175,7 @@ flowDataText :: forall env err m.
                 -> m CorpusId
 flowDataText u (DataOld ids) tt cid mfslw _ = do
   $(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)
   flowCorpusUser (_tt_lang tt) u userCorpusId listId corpusType mfslw
   where
@@ -187,7 +183,7 @@ flowDataText u (DataOld ids) tt cid mfslw _ = do
 flowDataText u (DataNew (mLen, txtC)) tt cid mfslw jobHandle = do
   $(logLocM) DEBUG $ T.pack $ "Found " <> show mLen <> " new documents to process"
   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
@@ -198,16 +194,15 @@ flowAnnuaire :: ( DbCmd' env err m
                 , HasTreeError err
                 , HasValidationError err
                 , MonadJobStatus m )
-             => User
-             -> Either CorpusName [CorpusId]
+             => MkCorpusUser
              -> TermType Lang
              -> FilePath
              -> JobHandle m
              -> m AnnuaireId
-flowAnnuaire u n l filePath jobHandle = do
+flowAnnuaire mkCorpusUser l filePath jobHandle = do
   -- TODO Conduit for file
-  docs <- liftBase $ (readFile_Annuaire filePath :: IO [HyperdataContact])
-  flow (Nothing :: Maybe HyperdataAnnuaire) u n l Nothing (fromIntegral $ length docs, yieldMany docs) jobHandle
+  docs <- liftBase (readFile_Annuaire filePath :: IO [HyperdataContact])
+  flow (Nothing :: Maybe HyperdataAnnuaire) mkCorpusUser l Nothing (fromIntegral $ length docs, yieldMany docs) jobHandle
 
 ------------------------------------------------------------------------
 flowCorpusFile :: ( DbCmd' env err m
@@ -217,8 +212,7 @@ flowCorpusFile :: ( DbCmd' env err m
                   , HasTreeError err
                   , HasValidationError err
                   , MonadJobStatus m )
-           => User
-           -> Either CorpusName [CorpusId]
+           => MkCorpusUser
            -> Limit -- Limit the number of docs (for dev purpose)
            -> TermType Lang
            -> FileType
@@ -227,11 +221,11 @@ flowCorpusFile :: ( DbCmd' env err m
            -> Maybe FlowSocialListWith
            -> JobHandle m
            -> 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
   case eParsed of
     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
       --flowCorpus u n la mfslw (yieldMany $ map (map toHyperdataDocument) docs) logStatus
     Left e       -> panicTrace $ "Error: " <> e
@@ -247,8 +241,7 @@ flowCorpus :: ( DbCmd' env err m
               , HasValidationError err
               , FlowCorpus a
               , MonadJobStatus m )
-           => User
-           -> Either CorpusName [CorpusId]
+           => MkCorpusUser
            -> TermType Lang
            -> Maybe FlowSocialListWith
            -> (Integer, ConduitT () a m ())
@@ -269,15 +262,14 @@ flow :: forall env err m a c.
         , MonadJobStatus m
         )
         => Maybe c
-        -> User
-        -> Either CorpusName [CorpusId]
+        -> MkCorpusUser
         -> TermType Lang
         -> Maybe FlowSocialListWith
         -> (Integer, ConduitT () a m ())
         -> JobHandle m
         -> m CorpusId
-flow c u cn la mfslw (count, docsC) jobHandle = do
-  (_userId, userCorpusId, listId) <- createNodes u cn c
+flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do
+  (_userId, userCorpusId, listId) <- createNodes mkCorpusUser c
   -- TODO if public insertMasterDocs else insertUserDocs
   nlpServer <- view $ nlpServerGet (_tt_lang la)
   runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC
@@ -285,6 +277,8 @@ flow c u cn la mfslw (count, docsC) jobHandle = do
     .| mapM_C (addDocumentsWithProgress nlpServer userCorpusId)
     .| sinkNull
 
+  let u = userFromMkCorpusUser mkCorpusUser
+    
   $(logLocM) DEBUG "Calling flowCorpusUser"
   flowCorpusUser (la ^. tt_lang) u userCorpusId listId c mfslw
 
@@ -318,13 +312,12 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do
 createNodes :: ( DbCmd' env err m, HasNodeError err
                , MkCorpus c
                )
-            => User
-            -> Either CorpusName [CorpusId]
+            => MkCorpusUser
             -> Maybe c
             -> m (UserId, CorpusId, ListId)
-createNodes user corpusName ctype = do
+createNodes mkCorpusUser ctype = do
   -- User Flow
-  (userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus user corpusName ctype
+  (userId, _rootId, userCorpusId) <- getOrMkRootWithCorpus mkCorpusUser ctype
   -- NodeTexts is first
   _tId <- insertDefaultNodeIfNotExists NodeTexts userCorpusId userId
   -- printDebug "NodeTexts: " tId
@@ -386,7 +379,7 @@ buildSocialList _l _user _userCorpusId _listId _ctype (Just (NoList _)) = pure (
 buildSocialList l user userCorpusId listId ctype mfslw = do
   -- User List Flow
   (masterUserId, _masterRootId, masterCorpusId)
-    <- getOrMk_RootWithCorpus (UserName userMaster) (Left "") ctype
+    <- getOrMkRootWithCorpus MkCorpusUserMaster ctype
 
   nlpServer <- view (nlpServerGet l)
   --let gp = (GroupParams l 2 3 (StopSize 3))
@@ -416,7 +409,7 @@ insertMasterDocs :: ( DbCmd' env err m
                  -> [a]
                  -> m [DocId]
 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 )
   _ <- Doc.add masterCorpusId ids'
   -- TODO

src/Gargantext/Database/Query/Tree/Root.hs

@@ -14,20 +14,19 @@ module Gargantext.Database.Query.Tree.Root
   where
 
 import Control.Arrow (returnA)
-import Gargantext.Core
+import Gargantext.Core (HasDBid(..))
 import Gargantext.Core.Types.Individu (User(..))
 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.Admin.Config
-import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
+import Gargantext.Database.Admin.Config ( corpusMasterName, userMaster )
+import Gargantext.Database.Admin.Types.Hyperdata.User ( HyperdataUser )
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (runOpaQuery, DBCmd)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
-import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead)
-import Gargantext.Database.Schema.Node (queryNodeTable)
+import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead, queryNodeTable)
 import Gargantext.Prelude
 import Opaleye (restrict, (.==), Select)
 import Opaleye.SqlTypes (sqlStrictText, sqlInt4)
@@ -61,30 +60,62 @@ getOrMkRoot user = do
   pure (userId, rootId)
 
 
-getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
-                      => User
-                      -> Either CorpusName [CorpusId]
+-- | Datatype for the `getOrMkRootWithCorpus`.
+-- There are only 3 possibilities:
+-- - 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
                       -> 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
-  corpusId'' <- if user == UserName userMaster
-                  then do
-                    ns <- getCorporaWithParentId rootId
-                    pure $ map _node_id ns
-                  else
-                    pure $ fromRight [] cName
-
-  corpusId' <- if corpusId'' /= []
-                  then pure corpusId''
-                  else do
-                    c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
-                    _tId <- case head c' of
-                              Nothing  -> errorWith "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
-                              Just c'' -> insertDefaultNode NodeTexts c'' userId
-                    pure c'
-
-  corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
+  corpusId <- maybe (nodeError NoCorpusFound) pure (head cIds)
+  pure (userId, rootId, corpusId)
+
+
+-- | Helper function for `getOrMkRootWithCorpus`.
+mkCorpus :: (HasNodeError err, MkCorpus a)
+         => CorpusName
+         -> Maybe a
+         -> RootId
+         -> UserId
+         -> DBCmd err (UserId, RootId, CorpusId)
+mkCorpus cName c rootId userId = do
+  c' <- mk (Just cName) c rootId userId
+  _tId <- case head c' of
+            Nothing  -> errorWith "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
+            Just c'' -> insertDefaultNode NodeTexts c'' userId
+
+  corpusId <- maybe (nodeError NoCorpusFound) pure (head c')
   pure (userId, rootId, corpusId)
 
 
@@ -118,20 +149,20 @@ selectRoot :: User -> Select NodeRead
 selectRoot (UserName username) = proc () -> do
     row   <- queryNodeTable -< ()
     users <- queryUserTable -< ()
-    restrict -< _node_typename row   .== (sqlInt4 $ toDBid NodeUser)
-    restrict -< user_username  users .== (sqlStrictText username)
-    restrict -< _node_user_id   row   .== (user_id users)
+    restrict -< _node_typename row   .== sqlInt4 (toDBid NodeUser)
+    restrict -< user_username  users .== sqlStrictText username
+    restrict -< _node_user_id   row   .== user_id users
     returnA  -< row
 
 selectRoot (UserDBId uid) = proc () -> do
     row   <- queryNodeTable -< ()
-    restrict -< _node_typename row   .== (sqlInt4 $ toDBid NodeUser)
-    restrict -< _node_user_id   row   .== (sqlInt4 $ _UserId uid)
+    restrict -< _node_typename row   .== sqlInt4 (toDBid NodeUser)
+    restrict -< _node_user_id   row   .== sqlInt4 (_UserId uid)
     returnA  -< row
 
 selectRoot (RootId nid) =
  proc () -> do
     row   <- queryNodeTable -< ()
-    restrict -< _node_typename row   .== (sqlInt4 $ toDBid NodeUser)
-    restrict -< _node_id   row   .== (pgNodeId nid)
+    restrict -< _node_typename row   .== sqlInt4 (toDBid NodeUser)
+    restrict -< _node_id   row   .== pgNodeId nid
     returnA  -< row

test/Test/API/Setup.hs

@@ -3,6 +3,7 @@
 
 module Test.API.Setup where
 
+-- import Gargantext.Prelude (printDebug)
 import Control.Lens
 import Control.Monad.Reader
 import Gargantext.API (makeApp)
@@ -21,24 +22,24 @@ import Gargantext.Database.Admin.Trigger.Init
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Prelude
 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.Mail qualified as Mail
+import Gargantext.Prelude.NLP qualified as NLP
 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.Wai (Application)
+import Network.Wai.Handler.Warp qualified as Warp
 import Prelude
 import Servant.Auth.Client ()
 import Servant.Client
+import Servant.Job.Async qualified as ServantAsync
 import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo)
 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
@@ -97,9 +98,7 @@ setupEnvironment env = flip runReaderT env $ runTestMonad $ do
   void $ initFirstTriggers "secret_key"
   void $ new_user $ mkNewUser (userMaster <> "@cnrs.com") (GargPassword "secret_key")
   (masterUserId, _masterRootId, masterCorpusId)
-              <- getOrMk_RootWithCorpus (UserName userMaster)
-                                        (Left corpusMasterName)
-                                        (Nothing :: Maybe HyperdataCorpus)
+              <- getOrMkRootWithCorpus MkCorpusUserMaster (Nothing :: Maybe HyperdataCorpus)
   masterListId <- getOrMkList masterCorpusId masterUserId
   -- printDebug "[setupEnvironment] masterListId: " masterListId
   void $ initLastTriggers masterListId

test/Test/Ngrams/Query.hs

@@ -36,7 +36,7 @@ mockFlatCorpus = Versioned 0 $ Map.fromList [
 
 mockQueryFn :: Maybe T.Text -> NgramsTerm -> Bool
 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 = testGroup "Query tests"