[FLOW] FIX listUser, but still repo.json is empty

src/Gargantext/API/Ngrams.hs

@@ -644,9 +644,9 @@ something :: Monoid a => Maybe a -> a
 something Nothing  = mempty
 something (Just a) = a
 
-insertNewListOfNgramsElements :: RepoCmdM env err m => NodeId -> NgramsType
+putListNgrams :: RepoCmdM env err m => NodeId -> NgramsType
                               -> [NgramsElement] -> m ()
-insertNewListOfNgramsElements listId ngramsType nes = do
+putListNgrams listId ngramsType nes = do
   var <- view repoVar
   liftIO $ modifyMVar_ var $
     pure . (r_state . at ngramsType %~ (Just . (at listId %~ insertNewOnly m) . something))

src/Gargantext/Database/Flow.hs

@@ -20,10 +20,11 @@ module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
     where
 
 --import Control.Lens (view)
+import Control.Monad (mapM_)
 import Control.Monad.IO.Class (liftIO)
 --import Gargantext.Core.Types
 --import Gargantext.Database.Node.Contact (HyperdataContact(..))
-import Data.Map (Map, lookup)
+import Data.Map (Map, lookup, fromListWith, toList)
 import Data.Maybe (Maybe(..), catMaybes)
 import Data.Monoid
 import Data.Text (Text, splitOn, intercalate)
@@ -57,7 +58,7 @@ import Gargantext.Text.Parsers (parseDocs, FileFormat)
 import System.FilePath (FilePath)
 import Gargantext.API.Ngrams (HasRepoVar)
 import Servant (ServantErr)
-import Gargantext.API.Ngrams (NgramsElement(..), insertNewListOfNgramsElements, RepoCmdM)
+import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams, RepoCmdM)
 --import Gargantext.Database.Schema.User (insertUsers, simpleUser, gargantuaUser)
 import qualified Data.Map as DM
 
@@ -92,27 +93,6 @@ flowInsert _nt hyperdataDocuments cName = do
   pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
 
 
-flowAnnuaire :: FlowCmdM env ServantErr m => FilePath -> m ()
-flowAnnuaire filePath = do
-  contacts <- liftIO $ deserialiseImtUsersFromFile filePath
-  ps <- flowInsertAnnuaire "Annuaire" $ map (\h-> ToDbContact h) $ map addUniqIdsContact contacts
-  printDebug "length annuaire" ps
-
-
-flowInsertAnnuaire :: HasNodeError err => CorpusName -> [ToDbData]
-                    -> Cmd err ([ReturnId], UserId, CorpusId, UserId, CorpusId)
-flowInsertAnnuaire name children = do
-
-  (masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
-  ids  <- insertDocuments masterUserId masterCorpusId NodeContact children
-
-  (userId, _, userCorpusId) <- subFlowAnnuaire userArbitrary name
-  _ <- add userCorpusId (map reId ids)
-
-  printDebug "AnnuaireID" userCorpusId
-
-  pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
-
 -- TODO-ACCESS:
 --   check userId       CanFillUserCorpus   userCorpusId
 --   check masterUserId CanFillMasterCorpus masterCorpusId
@@ -126,24 +106,23 @@ flowCorpus' :: FlowCmdM env err m
             -> m CorpusId
 flowCorpus' NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, userId,userCorpusId) = do
 --------------------------------------------------
-  -- List Ngrams Flow
-  userListId <- flowListUser userId userCorpusId 500
-  printDebug "Working on User ListId : " userListId
 
   let documentsWithId = mergeData (toInserted ids) (toInsert hyperdataDocuments)
-  printDebug "documentsWithId" documentsWithId
+  --printDebug "documentsWithId" documentsWithId
   docsWithNgrams <- documentIdWithNgrams extractNgramsT documentsWithId
-  printDebug "docsWithNgrams" docsWithNgrams
+  --printDebug "docsWithNgrams" docsWithNgrams
   let maps            = mapNodeIdNgrams docsWithNgrams
 
-  -- printDebug "maps" (maps)
+  --printDebug "maps" (maps)
   terms2id <- insertNgrams $ DM.keys maps
   let indexedNgrams = DM.mapKeys (indexNgrams terms2id) maps
-  printDebug "inserted ngrams" indexedNgrams
+  --printDebug "inserted ngrams" indexedNgrams
   _             <- insertToNodeNgrams indexedNgrams
 
-  listId2    <- flowList masterUserId masterCorpusId indexedNgrams
-  printDebug "Working on ListId : " listId2
+  -- List Ngrams Flow
+  _masterListId <- flowList masterUserId masterCorpusId indexedNgrams
+  _userListId    <- flowListUser userId userCorpusId 500
+  --printDebug "Working on User ListId : " userListId
   --}
 --------------------------------------------------
   _ <- mkDashboard userCorpusId userId
@@ -169,19 +148,19 @@ subFlowCorpus username cName = do
         -- mk NodeUser gargantua_id "Node Gargantua"
         Just user -> pure $ userLight_id user
 
-  printDebug "userId" userId
+  --printDebug "userId" userId
   rootId' <- map _node_id <$> getRoot username
 
-  printDebug "rootId'" rootId'
+  --printDebug "rootId'" rootId'
   rootId'' <- case rootId' of
         []  -> mkRoot username userId
         n   -> case length n >= 2 of
             True  -> nodeError ManyNodeUsers
             False -> pure rootId'
 
-  printDebug "rootId''" rootId''
+  --printDebug "rootId''" rootId''
   rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
-  
+
   corpusId'' <- if username == userMaster
                   then do
                     ns <- getCorporaWithParentId rootId
@@ -195,38 +174,11 @@ subFlowCorpus username cName = do
 
   corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
 
-  printDebug "(username, userId, rootId, corpusId)"
-              (username, userId, rootId, corpusId)
+  --printDebug "(username, userId, rootId, corpusId)"
+  --            (username, userId, rootId, corpusId)
   pure (userId, rootId, corpusId)
 
 
-subFlowAnnuaire :: HasNodeError err =>
-  Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
-subFlowAnnuaire username _cName = do
-  maybeUserId <- getUser username
-
-  userId <- case maybeUserId of
-        Nothing   -> nodeError NoUserFound
-        -- mk NodeUser gargantua_id "Node Gargantua"
-        Just user -> pure $ userLight_id user
-
-  rootId' <- map _node_id <$> getRoot username
-
-  rootId'' <- case rootId' of
-        []  -> mkRoot username userId
-        n   -> case length n >= 2 of
-            True  -> nodeError ManyNodeUsers
-            False -> pure rootId'
-  rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
-
-  corpusId' <- mkAnnuaire rootId userId
-
-  corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
-
-  printDebug "(username, userId, rootId, corpusId)"
-              (username, userId, rootId, corpusId)
-  pure (userId, rootId, corpusId)
-
 ------------------------------------------------------------------------
 toInsert :: [HyperdataDocument] -> Map HashId HyperdataDocument
 toInsert = DM.fromList . map (\d -> (maybe err identity (_hyperdataDocument_uniqId d), d))
@@ -291,20 +243,21 @@ mapNodeIdNgrams = DM.unionsWith (DM.unionWith (DM.unionWith (+))) . fmap f
         nId = documentId $ documentWithId d
 
 ------------------------------------------------------------------------
-flowList :: HasNodeError err => UserId -> CorpusId
-         -> Map NgramsIndexed (Map NgramsType (Map NodeId Int)) -> Cmd err ListId
+flowList :: FlowCmdM env err m => UserId -> CorpusId
+         -> Map NgramsIndexed (Map NgramsType (Map NodeId Int))
+         -> m ListId
 flowList uId cId ngs = do
-  -- printDebug "ngs:" ngs
+  --printDebug "ngs:" ngs
   lId <- getOrMkList cId uId
-  printDebug "ngs" (DM.keys ngs)
+  --printDebug "ngs" (DM.keys ngs)
   -- TODO add stemming equivalence of 2 ngrams
   -- TODO needs rework
   -- let groupEd = groupNgramsBy (\(NgramsT t1 n1) (NgramsT t2 n2) -> if (((==) t1 t2) && ((==) n1 n2)) then (Just (n1,n2)) else Nothing) ngs
   -- _ <- insertGroups lId groupEd
 
 -- compute Candidate / Map
-  is <- insertLists lId $ ngrams2list ngs
-  printDebug "listNgrams inserted :" is
+  _is <- mapM_ (\(typeList, ngElements) -> putListNgrams lId typeList ngElements) $ toList $ ngrams2list' ngs
+  --printDebug "listNgrams inserted :" is
 
   pure lId
 
@@ -312,12 +265,11 @@ flowListUser :: FlowCmdM env err m
              => UserId -> CorpusId -> Int -> m ListId
 flowListUser uId cId n = do
   lId <- getOrMkList cId uId
-  -- is <- insertLists lId $ ngrams2list ngs
 
-  ngs <- take n <$> sortWith tficf_score <$> getTficf userMaster cId lId NgramsTerms
---  _ <- insertNodeNgrams [ NodeNgram lId (tficf_ngramsId ng) Nothing (ngramsTypeId NgramsTerms) (fromIntegral $ listTypeId GraphList) 1 | ng <- ngs]
+  ngs <- take n <$> sortWith tficf_score
+                <$> getTficf userMaster cId lId NgramsTerms
 
-  insertNewListOfNgramsElements lId NgramsTerms $
+  putListNgrams lId NgramsTerms $
     [ NgramsElement (tficf_ngramsTerms ng) GraphList 1 Nothing mempty
     | ng <- ngs ]
 
@@ -346,16 +298,82 @@ insertGroups lId ngrs =
 
 ------------------------------------------------------------------------
 ngrams2list :: Map NgramsIndexed (Map NgramsType a)
-            -> [(ListType, (NgramsType,NgramsIndexed))]
+            -> [(ListType, (NgramsType, NgramsIndexed))]
 ngrams2list m =
   [ (CandidateList, (t, ng))
   | (ng, tm) <- DM.toList m
   , t <- DM.keys tm
   ]
 
+ngrams2list' :: Map NgramsIndexed (Map NgramsType a)
+            -> Map NgramsType [NgramsElement]
+ngrams2list' m = fromListWith (<>)
+  [ (t, [NgramsElement (_ngramsTerms $ _ngrams ng) CandidateList 1 Nothing mempty])
+  | (ng, tm) <- DM.toList m
+  , t <- DM.keys tm
+  ]
+
+
+
+
+
 -- | TODO: weight of the list could be a probability
 insertLists :: HasNodeError err => ListId -> [(ListType, (NgramsType, NgramsIndexed))] -> Cmd err Int
 insertLists lId lngs = insertNodeNgrams [ NodeNgram lId (_ngramsId ng) Nothing (ngramsTypeId ngt) (fromIntegral $ listTypeId l) 1
                      | (l,(ngt, ng)) <- lngs
                    ]
 ------------------------------------------------------------------------
+
+
+-- | Annuaire
+
+flowAnnuaire :: FlowCmdM env ServantErr m => FilePath -> m ()
+flowAnnuaire filePath = do
+  contacts <- liftIO $ deserialiseImtUsersFromFile filePath
+  ps <- flowInsertAnnuaire "Annuaire" $ map (\h-> ToDbContact h) $ map addUniqIdsContact contacts
+  printDebug "length annuaire" ps
+
+
+flowInsertAnnuaire :: HasNodeError err => CorpusName -> [ToDbData]
+                    -> Cmd err ([ReturnId], UserId, CorpusId, UserId, CorpusId)
+flowInsertAnnuaire name children = do
+
+  (masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
+  ids  <- insertDocuments masterUserId masterCorpusId NodeContact children
+
+  (userId, _, userCorpusId) <- subFlowAnnuaire userArbitrary name
+  _ <- add userCorpusId (map reId ids)
+
+  printDebug "AnnuaireID" userCorpusId
+
+  pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
+
+
+subFlowAnnuaire :: HasNodeError err =>
+  Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
+subFlowAnnuaire username _cName = do
+  maybeUserId <- getUser username
+
+  userId <- case maybeUserId of
+        Nothing   -> nodeError NoUserFound
+        -- mk NodeUser gargantua_id "Node Gargantua"
+        Just user -> pure $ userLight_id user
+
+  rootId' <- map _node_id <$> getRoot username
+
+  rootId'' <- case rootId' of
+        []  -> mkRoot username userId
+        n   -> case length n >= 2 of
+            True  -> nodeError ManyNodeUsers
+            False -> pure rootId'
+  rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
+
+  corpusId' <- mkAnnuaire rootId userId
+
+  corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
+
+  printDebug "(username, userId, rootId, corpusId)"
+              (username, userId, rootId, corpusId)
+  pure (userId, rootId, corpusId)
+
+