[MERGE] Ngrams repos fixes

src/Gargantext/API/Ngrams/Tools.hs

@@ -33,24 +33,28 @@ import qualified Data.Set as Set
 
 type RootTerm = Text
 
--- TODO-ACCESS: We want to do the security check before entering here.
---              Add a static capability parameter would be nice.
---              Ideally this is the access to `repoVar` which needs to
---              be properly guarded.
-getListNgrams :: RepoCmdM env err m
-               => [ListId] -> NgramsType
-               -> m (Map Text NgramsRepoElement)
-getListNgrams nodeIds ngramsType = do
-  v    <- view repoVar
-  repo <- liftIO $ readMVar v
-
-  let
+getRepo :: RepoCmdM env err m => m NgramsRepo
+getRepo = do
+  v <- view repoVar
+  liftIO $ readMVar v
+
+listNgramsFromRepo :: [ListId] -> NgramsType
+                   -> NgramsRepo -> Map Text NgramsRepoElement
+listNgramsFromRepo nodeIds ngramsType repo = ngrams
+  where
     ngramsMap = repo ^. r_state . at ngramsType . _Just
 
     ngrams    = Map.unionsWith mergeNgramsElement
               [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
 
-  pure ngrams
+-- TODO-ACCESS: We want to do the security check before entering here.
+--              Add a static capability parameter would be nice.
+--              Ideally this is the access to `repoVar` which needs to
+--              be properly guarded.
+getListNgrams :: RepoCmdM env err m
+              => [ListId] -> NgramsType
+              -> m (Map Text NgramsRepoElement)
+getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
 
 getTermsWith :: (RepoCmdM env err m, Ord a)
           => (Text -> a ) -> [ListId]
@@ -61,19 +65,19 @@ getTermsWith f ls ngt lt = Map.fromListWith (<>)
                       <$> Map.toList
                       <$> Map.filter (\f' -> (fst f') == lt)
                       <$> mapTermListRoot ls ngt
+                      <$> getRepo
   where
     toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of
       Nothing -> (f'' t, [])
       Just  r -> (f'' r, map f'' [t])
 
-mapTermListRoot :: RepoCmdM env err m
-               => [ListId] -> NgramsType
-               -> m (Map Text (ListType, (Maybe Text)))
-mapTermListRoot nodeIds ngramsType = do
-  ngrams <- getListNgrams nodeIds ngramsType
-  pure $ Map.fromList [ (t, (_nre_list nre, _nre_root nre))
-                      | (t, nre) <- Map.toList ngrams
-                      ]
+mapTermListRoot :: [ListId] -> NgramsType
+                -> NgramsRepo -> Map Text (ListType, (Maybe Text))
+mapTermListRoot nodeIds ngramsType repo =
+  Map.fromList [ (t, (_nre_list nre, _nre_root nre))
+               | (t, nre) <- Map.toList ngrams
+               ]
+  where ngrams = listNgramsFromRepo nodeIds ngramsType repo
 
 filterListWithRoot :: ListType -> Map Text (ListType, Maybe Text)
                       -> Map Text (Maybe RootTerm)

src/Gargantext/Database/Metrics.hs

@@ -21,7 +21,7 @@ module Gargantext.Database.Metrics
 import Data.Map (Map)
 import Data.Text (Text)
 import Gargantext.API.Ngrams (TabType(..), ngramsTypeFromTabType)
-import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm)
+import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo)
 import Gargantext.Core.Types (ListType(..), Limit, NodeType(..))
 import Gargantext.Database.Flow (FlowCmdM)
 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser{-, getTficfWith-})
@@ -76,7 +76,7 @@ getNgrams cId maybeListId tabType = do
     Nothing   -> defaultList cId
     Just lId' -> pure lId'
 
-  lists    <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType)
+  lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo
   let maybeSyn = Map.unions $ map (\t -> filterListWithRoot t lists)
                              [GraphTerm, StopTerm, CandidateTerm]
   pure (lists, maybeSyn)

src/Gargantext/Viz/Chart.hs

@@ -72,7 +72,7 @@ pieData :: FlowCmdM env err m
 pieData cId nt lt = do
   ls' <- selectNodesWithUsername NodeList userMaster
   ls <- map (_node_id) <$> getListsWithParentId cId
-  ts <- mapTermListRoot ls nt
+  ts <- mapTermListRoot ls nt <$> getRepo
   let
     dico = filterListWithRoot lt ts
     terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ Map.toList dico
@@ -94,7 +94,7 @@ treeData :: FlowCmdM env err m
 treeData cId nt lt = do
   ls' <- selectNodesWithUsername NodeList userMaster
   ls <- map (_node_id) <$> getListsWithParentId cId
-  ts <- mapTermListRoot ls nt
+  ts <- mapTermListRoot ls nt <$> getRepo
   
   let
     dico = filterListWithRoot lt ts
@@ -112,7 +112,7 @@ treeData' :: FlowCmdM env ServerError m
 treeData' cId nt lt = do
   ls' <- selectNodesWithUsername NodeList userMaster
   ls <- map (_node_id) <$> getListsWithParentId cId
-  ts <- mapTermListRoot ls nt
+  ts <- mapTermListRoot ls nt <$> getRepo
   
   let
     dico = filterListWithRoot lt ts

src/Gargantext/Viz/Graph/API.hs

@@ -28,7 +28,7 @@ import Debug.Trace (trace)
 import Control.Lens (set, (^.), _Just, (^?))
 import Control.Monad.IO.Class (liftIO)
 import Data.Maybe (Maybe(..))
-import Gargantext.API.Ngrams (currentVersion)
+import Gargantext.API.Ngrams (NgramsRepo, r_version)
 import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Types
 import Gargantext.Core.Types.Main
@@ -36,9 +36,10 @@ import Gargantext.Database.Config
 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
 import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Node.Select
-import Gargantext.Database.Schema.Node (getNodeWith, defaultList, insertGraph)
+import Gargantext.Database.Schema.Node (getNodeWith, defaultList, insertGraph, HasNodeError)
 import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
 import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Utils (Cmd)
 import Gargantext.Prelude
 import Gargantext.Viz.Graph
 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
@@ -71,7 +72,8 @@ getGraph uId nId = do
                             . gm_list
                             . lfg_version
 
-  v <- currentVersion
+  repo <- getRepo
+  let v = repo ^. r_version
   nodeUser <- getNodeWith (NodeId uId) HyperdataUser
 
   let uId' = nodeUser ^. node_userId
@@ -79,36 +81,36 @@ getGraph uId nId = do
   let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
                   identity
                   $ nodeGraph ^. node_parentId
-  
+
   g <- case graph of
     Nothing     -> do
-      graph' <- computeGraph cId NgramsTerms v
+      graph' <- computeGraph cId NgramsTerms repo
       _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
       pure graph'
 
     Just graph' -> if listVersion == Just v
                      then pure graph'
                      else do
-                       graph'' <- computeGraph cId NgramsTerms v
+                       graph'' <- computeGraph cId NgramsTerms repo
                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
                        pure graph''
   pure $ trace ("salut" <> show g) $ g
 
 
 -- TODO use Database Monad only here ?
-computeGraph :: CorpusId -> NgramsType -> Int -> GargServer (Get '[JSON] Graph)
-computeGraph cId nt v = do
+computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
+computeGraph cId nt repo = do
   lId  <- defaultList cId
 
   let metadata = GraphMetadata "Title" [cId]
                                      [ LegendField 1 "#FFF" "Cluster"
                                      , LegendField 2 "#FFF" "Cluster"
                                      ]
-                                (ListForGraph lId v)
+                                (ListForGraph lId (repo ^. r_version))
                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 
   lIds <- selectNodesWithUsername NodeList userMaster
-  ngs  <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] nt
+  let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 
   myCooc <- Map.filter (>1)
          <$> getCoocByNgrams (Diagonal True)