[FIX] list heritage (into NodeStory)

src/Gargantext/API/Ngrams.hs

@@ -249,7 +249,7 @@ setListNgrams ::  HasNodeStory env err m
 setListNgrams listId ngramsType ns = do
   printDebug "[setListNgrams]" (listId, ngramsType)
   getter <- view hasNodeStory
-  var <- liftBase $ (getter ^. nse_getter) listId
+  var <- liftBase $ (getter ^. nse_getter) [listId]
   liftBase $ modifyMVar_ var $
     pure . ( unNodeStory
            . at listId . _Just
@@ -286,7 +286,7 @@ commitStatePatch :: HasNodeStory env err m
                  -> m (Versioned NgramsStatePatch')
 commitStatePatch listId (Versioned p_version p) = do
   printDebug "[commitStatePatch]" listId
-  var <- getRepoVar listId
+  var <- getRepoVar [listId]
   vq' <- liftBase $ modifyMVar var $ \ns -> do
     let
       a = ns ^. unNodeStory . at listId . _Just
@@ -328,7 +328,7 @@ tableNgramsPull :: HasNodeStory env err m
                 -> m (Versioned NgramsTablePatch)
 tableNgramsPull listId ngramsType p_version = do
   printDebug "[tableNgramsPull]" (listId, ngramsType)
-  var <- getRepoVar listId
+  var <- getRepoVar [listId]
   r <- liftBase $ readMVar var
 
   let
@@ -467,7 +467,7 @@ getNgramsTableMap :: HasNodeStory env err m
                   -> TableNgrams.NgramsType
                   -> m (Versioned NgramsTableMap)
 getNgramsTableMap nodeId ngramsType = do
-  v    <- getRepoVar nodeId
+  v    <- getRepoVar [nodeId]
   repo <- liftBase $ readMVar v
   pure $ Versioned (repo ^. unNodeStory . at nodeId . _Just . a_version)
                    (repo ^. unNodeStory . at nodeId . _Just . a_state . at ngramsType . _Just)

src/Gargantext/API/Ngrams/Tools.hs

@@ -28,7 +28,6 @@ import Gargantext.Prelude
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map.Strict     as Map
 import qualified Data.Set            as Set
-import qualified Data.List           as List
 import Gargantext.Core.NodeStory
 
 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
@@ -46,43 +45,32 @@ getRepo = do
 getRepo' :: HasNodeStory env err m
          => [ListId] -> m NodeListStory
 getRepo' listIds = do
-  maybeNodeListStory <- head <$> List.reverse <$> mapM getNodeListStory'' listIds
-  case maybeNodeListStory of
-    Nothing  -> panic "[G.A.N.Tools.getRepo']"
-    Just nls -> pure nls 
+  f <- getNodeListStory
+  v  <- liftBase $ f listIds
+  v' <- liftBase $ readMVar v
+  pure $ v'
+
 
 getRepoVar :: HasNodeStory env err m
-           => ListId -> m (MVar NodeListStory)
+           => [ListId] -> m (MVar NodeListStory)
 getRepoVar l = do
   f <- getNodeListStory
   v  <- liftBase $ f l
   pure v
 
+
 getNodeListStory :: HasNodeStory env err m
-                 => m (NodeId -> IO (MVar NodeListStory))
+                 => m ([NodeId] -> IO (MVar NodeListStory))
 getNodeListStory = do
   env <- view hasNodeStory
   pure $ view nse_getter env
 
-getNodeListStory' :: HasNodeStory env err m
-                 => NodeId -> m (IO NodeListStory)
-getNodeListStory' n = do
-  f <- getNodeListStory
-  v <- liftBase $ f n
-  pure $ readMVar v
-
-getNodeListStory'' :: HasNodeStory env err m
-                 => NodeId -> m NodeListStory
-getNodeListStory'' n = do
-  f <- getNodeListStory
-  v  <- liftBase $ f n
-  v' <- liftBase $ readMVar v
-  pure $ v'
-
 
 
-listNgramsFromRepo :: [ListId] -> NgramsType
-                   -> NodeListStory -> HashMap NgramsTerm NgramsRepoElement
+listNgramsFromRepo :: [ListId]
+                   -> NgramsType
+                   -> NodeListStory
+                   -> HashMap NgramsTerm NgramsRepoElement
 listNgramsFromRepo nodeIds ngramsType repo =
   HM.fromList $ Map.toList
               $ Map.unionsWith mergeNgramsElement ngrams

src/Gargantext/Core/NodeStory.hs

@@ -7,6 +7,10 @@ Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
 
+TODO:
+- remove
+- filter
+- charger les listes
 -}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -35,7 +39,7 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
 import Gargantext.Prelude
-import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist)
+import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
 import System.IO (FilePath, hClose)
 import System.IO.Temp (withTempFile)
 import qualified Data.ByteString.Lazy                   as DBL
@@ -48,7 +52,7 @@ import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 data NodeStoryEnv = NodeStoryEnv
   { _nse_var    :: !(MVar NodeListStory)
   , _nse_saver  :: !(IO ())
-  , _nse_getter :: NodeId -> IO (MVar NodeListStory)
+  , _nse_getter :: [NodeId] -> IO (MVar NodeListStory)
   --, _nse_cleaner :: !(IO ()) -- every 12 hours: cleans the repos of unused NodeStories
   -- , _nse_lock  :: !FileLock -- TODO (it depends on the option: if with database or file only)
   }
@@ -68,7 +72,7 @@ class (HasNodeStoryVar env, HasNodeStorySaver env)
     hasNodeStory :: Getter env NodeStoryEnv
 
 class HasNodeStoryVar env where
-  hasNodeStoryVar :: Getter env (NodeId -> IO (MVar NodeListStory))
+  hasNodeStoryVar :: Getter env ([NodeId] -> IO (MVar NodeListStory))
 
 class HasNodeStorySaver env where
   hasNodeStorySaver :: Getter env (IO ())
@@ -76,7 +80,7 @@ class HasNodeStorySaver env where
 ------------------------------------------------------------------------
 readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
 readNodeStoryEnv nsd = do
-  mvar  <- nodeStoryVar nsd Nothing 0
+  mvar  <- nodeStoryVar nsd Nothing [0]
   saver <- mkNodeStorySaver nsd mvar
   pure $ NodeStoryEnv mvar saver (nodeStoryVar nsd (Just mvar))
 
@@ -94,11 +98,11 @@ mkNodeStorySaver nsd mvns = mkDebounce settings
 
 nodeStoryVar :: NodeStoryDir
              -> Maybe (MVar NodeListStory)
-             -> NodeId
+             -> [NodeId]
              -> IO (MVar NodeListStory)
-nodeStoryVar nsd Nothing ni = nodeStoryInc nsd Nothing ni >>= newMVar
+nodeStoryVar nsd Nothing ni = nodeStoryIncs nsd Nothing ni >>= newMVar
 nodeStoryVar nsd (Just mv) ni = do
-  _ <- modifyMVar_ mv $ \mv' -> (nodeStoryInc nsd (Just mv') ni)
+  _ <- modifyMVar_ mv $ \mv' -> (nodeStoryIncs nsd (Just mv') ni)
   pure mv
 
 
@@ -112,6 +116,32 @@ nodeStoryInc nsd (Just ns@(NodeStory nls)) ni = do
 nodeStoryInc nsd Nothing ni = nodeStoryRead nsd ni
 
 
+nodeStoryIncs :: NodeStoryDir
+              -> Maybe NodeListStory
+              -> [NodeId]
+              -> IO NodeListStory
+nodeStoryIncs _ Nothing    []        = panic "nodeStoryIncs: Empty"
+nodeStoryIncs nsd (Just nls) ns      = foldM (\m n -> nodeStoryInc nsd (Just m) n) nls ns
+nodeStoryIncs nsd Nothing    (ni:ns) = do
+  m <- nodeStoryRead nsd ni
+  nodeStoryIncs nsd (Just m) ns
+
+
+nodeStoryDec :: NodeStoryDir
+             -> NodeListStory
+             -> NodeId
+             -> IO NodeListStory
+nodeStoryDec nsd ns@(NodeStory nls) ni = do
+  case Map.lookup ni nls of
+    Nothing -> do
+      -- we make sure the corresponding file repo is really removed
+      _ <- nodeStoryRemove nsd ni
+      pure ns
+    Just _  -> do
+      let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
+      _ <- nodeStoryRemove nsd ni
+      pure $ NodeStory ns'
+
 -- | TODO lock
 nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
 nodeStoryRead nsd ni = do
@@ -122,6 +152,16 @@ nodeStoryRead nsd ni = do
      then deserialise <$> DBL.readFile nsp
      else pure (initNodeStory ni)
 
+nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
+nodeStoryRemove nsd ni = do
+  let nsp = nodeStoryPath nsd ni
+  exists <- doesFileExist nsp
+  if exists
+     then removeFile nsp
+     else pure ()
+
+
+
 nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
 nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
                           $ fmap Map.keys

src/Gargantext/Database/Action/Flow/List.hs

@@ -178,7 +178,7 @@ putListNgrams' listId ngramsType ns = do
   -- The modifyMVar_ would test the patch with applicable first.
   -- If valid the rest would be atomic and no merge is required.
   -}
-  var <- getRepoVar listId
+  var <- getRepoVar [listId]
   liftBase $ modifyMVar_ var $ \r -> do
     pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
              & unNodeStory . at listId . _Just . a_history %~ (p :)