Commit 5705c4d3 authored by Nicolas Pouillard's avatar Nicolas Pouillard

[NGRAMS-TABLE] Refactoring to make more explicit the repo access

parent 7f6848cd
...@@ -33,24 +33,28 @@ import qualified Data.Set as Set ...@@ -33,24 +33,28 @@ import qualified Data.Set as Set
type RootTerm = Text type RootTerm = Text
-- TODO-ACCESS: We want to do the security check before entering here. getRepo :: RepoCmdM env err m => m NgramsRepo
-- Add a static capability parameter would be nice. getRepo = do
-- Ideally this is the access to `repoVar` which needs to v <- view repoVar
-- be properly guarded. liftIO $ readMVar v
getListNgrams :: RepoCmdM env err m
=> [ListId] -> NgramsType listNgramsFromRepo :: [ListId] -> NgramsType
-> m (Map Text NgramsRepoElement) -> NgramsRepo -> Map Text NgramsRepoElement
getListNgrams nodeIds ngramsType = do listNgramsFromRepo nodeIds ngramsType repo = ngrams
v <- view repoVar where
repo <- liftIO $ readMVar v
let
ngramsMap = repo ^. r_state . at ngramsType . _Just ngramsMap = repo ^. r_state . at ngramsType . _Just
ngrams = Map.unionsWith mergeNgramsElement ngrams = Map.unionsWith mergeNgramsElement
[ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ] [ 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) getTermsWith :: (RepoCmdM env err m, Ord a)
=> (Text -> a ) -> [ListId] => (Text -> a ) -> [ListId]
...@@ -61,19 +65,19 @@ getTermsWith f ls ngt lt = Map.fromListWith (<>) ...@@ -61,19 +65,19 @@ getTermsWith f ls ngt lt = Map.fromListWith (<>)
<$> Map.toList <$> Map.toList
<$> Map.filter (\f' -> (fst f') == lt) <$> Map.filter (\f' -> (fst f') == lt)
<$> mapTermListRoot ls ngt <$> mapTermListRoot ls ngt
<$> getRepo
where where
toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of
Nothing -> (f'' t, []) Nothing -> (f'' t, [])
Just r -> (f'' r, map f'' [t]) Just r -> (f'' r, map f'' [t])
mapTermListRoot :: RepoCmdM env err m mapTermListRoot :: [ListId] -> NgramsType
=> [ListId] -> NgramsType -> NgramsRepo -> Map Text (ListType, (Maybe Text))
-> m (Map Text (ListType, (Maybe Text))) mapTermListRoot nodeIds ngramsType repo =
mapTermListRoot nodeIds ngramsType = do Map.fromList [ (t, (_nre_list nre, _nre_root nre))
ngrams <- getListNgrams nodeIds ngramsType | (t, nre) <- Map.toList ngrams
pure $ 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) filterListWithRoot :: ListType -> Map Text (ListType, Maybe Text)
-> Map Text (Maybe RootTerm) -> Map Text (Maybe RootTerm)
......
...@@ -21,7 +21,7 @@ module Gargantext.Database.Metrics ...@@ -21,7 +21,7 @@ module Gargantext.Database.Metrics
import Data.Map (Map) import Data.Map (Map)
import Data.Text (Text) import Data.Text (Text)
import Gargantext.API.Ngrams (TabType(..), ngramsTypeFromTabType) 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.Core.Types (ListType(..), Limit, NodeType(..))
import Gargantext.Database.Flow (FlowCmdM) import Gargantext.Database.Flow (FlowCmdM)
import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser{-, getTficfWith-}) import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser{-, getTficfWith-})
...@@ -76,7 +76,7 @@ getNgrams cId maybeListId tabType = do ...@@ -76,7 +76,7 @@ getNgrams cId maybeListId tabType = do
Nothing -> defaultList cId Nothing -> defaultList cId
Just lId' -> pure lId' Just lId' -> pure lId'
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo
let maybeSyn = Map.unions $ map (\t -> filterListWithRoot t lists) let maybeSyn = Map.unions $ map (\t -> filterListWithRoot t lists)
[GraphTerm, StopTerm, CandidateTerm] [GraphTerm, StopTerm, CandidateTerm]
pure (lists, maybeSyn) pure (lists, maybeSyn)
......
...@@ -72,7 +72,7 @@ pieData :: FlowCmdM env err m ...@@ -72,7 +72,7 @@ pieData :: FlowCmdM env err m
pieData cId nt lt = do pieData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt ts <- mapTermListRoot ls nt <$> getRepo
let let
dico = filterListWithRoot lt ts dico = filterListWithRoot lt ts
terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ Map.toList dico terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ Map.toList dico
...@@ -94,7 +94,7 @@ treeData :: FlowCmdM env err m ...@@ -94,7 +94,7 @@ treeData :: FlowCmdM env err m
treeData cId nt lt = do treeData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt ts <- mapTermListRoot ls nt <$> getRepo
let let
dico = filterListWithRoot lt ts dico = filterListWithRoot lt ts
...@@ -112,7 +112,7 @@ treeData' :: FlowCmdM env ServerError m ...@@ -112,7 +112,7 @@ treeData' :: FlowCmdM env ServerError m
treeData' cId nt lt = do treeData' cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt ts <- mapTermListRoot ls nt <$> getRepo
let let
dico = filterListWithRoot lt ts dico = filterListWithRoot lt ts
......
...@@ -75,7 +75,8 @@ getGraph nId = do ...@@ -75,7 +75,8 @@ getGraph nId = do
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10]) -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
lIds <- selectNodesWithUsername NodeList userMaster lIds <- selectNodesWithUsername NodeList userMaster
ngs <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] NgramsTerms repo <- getRepo
let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] NgramsTerms repo
myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal False) myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal False)
<$> groupNodesByNgrams ngs <$> groupNodesByNgrams ngs
......
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