[ngrams] MVar -> TVar refactoring

Also, some fixes to NodeStory (it inserts ngrams when saving node
story, when they don't exist).

gargantext.cabal

@@ -129,6 +129,7 @@ library
       Gargantext.Database.Admin.Types.Node
       Gargantext.Database.Prelude
       Gargantext.Database.Query.Facet
+      Gargantext.Database.Query.Table.Ngrams
       Gargantext.Database.Query.Table.NgramsPostag
       Gargantext.Database.Query.Table.Node
       Gargantext.Database.Query.Table.Node.Error
@@ -215,7 +216,6 @@ library
       Gargantext.Core.Methods.Similarities.Accelerate.SpeGen
       Gargantext.Core.Methods.Similarities.Conditional
       Gargantext.Core.Methods.Similarities.Distributional
-      Gargantext.Core.NodeStoryFile
       Gargantext.Core.Statistics
       Gargantext.Core.Text.Convert
       Gargantext.Core.Text.Corpus.API.Hal
@@ -329,7 +329,6 @@ library
       Gargantext.Database.Query.Table.Context
       Gargantext.Database.Query.Table.ContextNodeNgrams
       Gargantext.Database.Query.Table.ContextNodeNgrams2
-      Gargantext.Database.Query.Table.Ngrams
       Gargantext.Database.Query.Table.Node.Children
       Gargantext.Database.Query.Table.Node.Contact
       Gargantext.Database.Query.Table.Node.Document.Add
@@ -892,6 +891,7 @@ test-suite garg-test-tasty
       Test.Core.Utils
       Test.Database.Operations
       Test.Database.Operations.DocumentSearch
+      Test.Database.Operations.NodeStory
       Test.Database.Setup
       Test.Database.Types
       Test.Graph.Clustering
@@ -1002,6 +1002,7 @@ test-suite garg-test-hspec
       Test.API.Setup
       Test.Database.Operations
       Test.Database.Operations.DocumentSearch
+      Test.Database.Operations.NodeStory
       Test.Database.Setup
       Test.Database.Types
       Test.Utils

src/Gargantext/API/Admin/Settings.hs

@@ -186,8 +186,8 @@ newEnv logger port file = do
   !self_url_env  <- parseBaseUrl $ "http://0.0.0.0:" <> show port
   dbParam        <- databaseParameters file
   !pool          <- newPool dbParam
-  --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
-  !nodeStory_env <- readNodeStoryEnv pool
+  --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath config_env)
+  !nodeStory_env <- fromDBNodeStoryEnv pool
   !scrapers_env  <- newJobEnv defaultSettings manager_env
 
   secret        <- Jobs.genSecret

src/Gargantext/API/Dev.hs

@@ -38,9 +38,9 @@ withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
     newDevEnv logger = do
       cfg     <- readConfig         iniPath
       dbParam <- databaseParameters iniPath
-      --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
+      --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
       pool    <- newPool            dbParam
-      nodeStory_env <- readNodeStoryEnv pool
+      nodeStory_env <- fromDBNodeStoryEnv pool
       setts   <- devSettings devJwkFile
       mail    <- Mail.readConfig iniPath
       nlp_config <- NLP.readConfig iniPath

src/Gargantext/API/Ngrams.hs

@@ -87,7 +87,6 @@ module Gargantext.API.Ngrams
   )
   where
 
-import Control.Concurrent
 import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), msumOf, at, _Just, Each(..), (%%~), mapped, ifolded, to, withIndex, over)
 import Control.Monad.Reader
 import Data.Aeson.Text qualified as DAT
@@ -123,6 +122,7 @@ import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
 import Gargantext.Prelude hiding (log, to, toLower, (%))
 import Gargantext.Prelude.Clock (hasTime, getTime)
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
+import GHC.Conc (readTVar, writeTVar)
 import Prelude (error)
 import Servant hiding (Patch)
 
@@ -249,7 +249,6 @@ addListNgrams listId ngramsType nes = do
 -- | TODO: incr the Version number
 -- && should use patch
 -- UNSAFE
-
 setListNgrams :: HasNodeStory env err m
               => NodeId
               -> TableNgrams.NgramsType
@@ -257,15 +256,16 @@ setListNgrams :: HasNodeStory env err m
               -> m ()
 setListNgrams listId ngramsType ns = do
   -- printDebug "[setListNgrams]" (listId, ngramsType)
-  getter <- view hasNodeStory
-  var <- liftBase $ (getter ^. nse_getter) [listId]
-  liftBase $ modifyMVar_ var $
-    pure . ( unNodeStory
-           . at listId . _Just
-            . a_state
-              . at ngramsType
-              .~ Just ns
-           )
+  var <- getNodeStoryVar [listId]
+  liftBase $ atomically $ do
+    nls <- readTVar var
+    writeTVar var $
+      ( unNodeStory
+        . at listId . _Just
+        . a_state
+        . at ngramsType
+        .~ Just ns
+      ) nls
   saveNodeStory
 
 
@@ -292,57 +292,67 @@ commitStatePatch listId (Versioned _p_version p) = do
   -- printDebug "[commitStatePatch]" listId
   var <- getNodeStoryVar [listId]
   archiveSaver <- view hasNodeArchiveStoryImmediateSaver
-  vq' <- liftBase $ modifyMVar var $ \ns -> do
-    let
-      a = ns ^. unNodeStory . at listId . _Just
-      -- apply patches from version p_version to a ^. a_version
-      -- TODO Check this
-      --q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
-      q = mconcat $ a ^. a_history
-
-    --printDebug "[commitStatePatch] transformWith" (p,q)
-    -- let tws s = case s of
-    --       (Mod p) -> "Mod"
-    --       _ -> "Rpl"
-    -- printDebug "[commitStatePatch] transformWith" (tws $ p ^. _NgramsPatch, tws $ q ^. _NgramsPatch)
-
-    let
-      (p', q') = transformWith ngramsStatePatchConflictResolution p q
-      a' = a & a_version +~ 1
-             & a_state   %~ act p'
-             & a_history %~ (p' :)
-
-    {-
-    -- Ideally we would like to check these properties. However:
-    -- * They should be checked only to debug the code. The client data
-    --   should be able to trigger these.
-    -- * What kind of error should they throw (we are in IO here)?
-    -- * Should we keep modifyMVar?
-    -- * Should we throw the validation in an Exception, catch it around
-    --   modifyMVar and throw it back as an Error?
-    assertValid $ transformable p q
-    assertValid $ applicable p' (r ^. r_state)
-    -}
-    -- printDebug "[commitStatePatch] a version" (a ^. a_version)
-    -- printDebug "[commitStatePatch] a' version" (a' ^. a_version)
-    let newNs = ( ns & unNodeStory . at listId .~ (Just a')
-         , Versioned (a' ^. a_version) q'
-         )
-
-    -- NOTE Now is the only good time to save the archive history. We
-    -- have the handle to the MVar and we need to save its exact
-    -- snapshot. Node Story archive is a linear table, so it's only
-    -- couple of inserts, it shouldn't take long...
-
-    -- If we postponed saving the archive to the debounce action, we
-    -- would have issues like
-    -- https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/476
-    -- where the `q` computation from above (which uses the archive)
-    -- would cause incorrect patch application (before the previous
-    -- archive was saved and applied)
-    newNs' <- archiveSaver $ fst newNs
+  ns <- liftBase $ atomically $ readTVar var
+  let
+    a = ns ^. unNodeStory . at listId . _Just
+    -- apply patches from version p_version to a ^. a_version
+    -- TODO Check this
+    --q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
+    q = mconcat $ a ^. a_history
+
+  --printDebug "[commitStatePatch] transformWith" (p,q)
+  -- let tws s = case s of
+  --       (Mod p) -> "Mod"
+  --       _ -> "Rpl"
+  -- printDebug "[commitStatePatch] transformWith" (tws $ p ^. _NgramsPatch, tws $ q ^. _NgramsPatch)
 
-    pure (newNs', snd newNs)
+  let
+    (p', q') = transformWith ngramsStatePatchConflictResolution p q
+    a' = a & a_version +~ 1
+           & a_state   %~ act p'
+           & a_history %~ (p' :)
+
+  {-
+  -- Ideally we would like to check these properties. However:
+  -- * They should be checked only to debug the code. The client data
+  --   should be able to trigger these.
+  -- * What kind of error should they throw (we are in IO here)?
+  -- * Should we keep modifyMVar?
+  -- * Should we throw the validation in an Exception, catch it around
+  --   modifyMVar and throw it back as an Error?
+  assertValid $ transformable p q
+  assertValid $ applicable p' (r ^. r_state)
+  -}
+  -- printDebug "[commitStatePatch] a version" (a ^. a_version)
+  -- printDebug "[commitStatePatch] a' version" (a' ^. a_version)
+  let newNs = ( ns & unNodeStory . at listId .~ (Just a')
+       , Versioned (a' ^. a_version) q'
+       )
+
+  -- NOTE Now is the only good time to save the archive history. We
+  -- have the handle to the MVar and we need to save its exact
+  -- snapshot. Node Story archive is a linear table, so it's only
+  -- couple of inserts, it shouldn't take long...
+
+  -- NOTE This is changed now. Before we used MVar's, now it's TVars
+  -- (MVar's blocked). It was wrapped in withMVar before, now we read
+  -- the TVar, modify archive with archiveSaver, then write the tvar.
+
+  -- pure (newNs', snd newNs)
+  -- writeTVar var newNs'
+
+  --pure newNs
+
+  -- If we postponed saving the archive to the debounce action, we
+  -- would have issues like
+  -- https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/476
+  -- where the `q` computation from above (which uses the archive)
+  -- would cause incorrect patch application (before the previous
+  -- archive was saved and applied)
+  -- newNs' <- archiveSaver $ fst newNs
+  liftBase $ do
+    newNs' <- archiveSaver $ fst newNs
+    atomically $ writeTVar var newNs'
 
   -- Save new ngrams
   _ <- insertNgrams (newNgramsFromNgramsStatePatch p)
@@ -350,7 +360,7 @@ commitStatePatch listId (Versioned _p_version p) = do
   -- saveNodeStory
   saveNodeStoryImmediate
 
-  pure vq'
+  pure $ snd newNs
 
 
 
@@ -363,7 +373,7 @@ tableNgramsPull :: HasNodeStory env err m
 tableNgramsPull listId ngramsType p_version = do
   -- printDebug "[tableNgramsPull]" (listId, ngramsType)
   var <- getNodeStoryVar [listId]
-  r <- liftBase $ readMVar var
+  r <- liftBase $ atomically $ readTVar var
 
   let
     a = r ^. unNodeStory . at listId . _Just
@@ -491,7 +501,7 @@ getNgramsTableMap :: HasNodeStory env err m
                   -> m (Versioned NgramsTableMap)
 getNgramsTableMap nodeId ngramsType = do
   v    <- getNodeStoryVar [nodeId]
-  repo <- liftBase $ readMVar v
+  repo <- liftBase $ atomically $ readTVar v
   pure $ Versioned (repo ^. unNodeStory . at nodeId . _Just . a_version)
                    (repo ^. unNodeStory . at nodeId . _Just . a_state . at ngramsType . _Just)
 

src/Gargantext/API/Ngrams/List.hs

@@ -31,6 +31,7 @@ import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Ngrams (setListNgrams)
 import Gargantext.API.Ngrams.List.Types
 import Gargantext.API.Ngrams.Prelude (getNgramsList)
+import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Prelude (GargServer, GargM, GargError)
 import Gargantext.API.Types
@@ -47,6 +48,7 @@ import Gargantext.Database.Types (Indexed(..))
 import Gargantext.Prelude hiding (concat, toList)
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
 import Gargantext.Utils.Servant qualified as GUS
+import GHC.Conc (readTVar)
 import Prelude qualified
 import Protolude qualified as P
 import Servant
@@ -122,7 +124,11 @@ setList :: HasNodeStory env err m
 setList l m  = do
   -- TODO check with Version for optim
   -- printDebug "New list as file" l
-  _ <- mapM (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList m
+  _ <- mapM (\(nt, Versioned _v ns) -> (setListNgrams l nt ns)) $ toList m
+  v <- getNodeStoryVar [l]
+  -- liftBase $ do
+  --   ns <- atomically $ readTVar v
+  --   printDebug "[setList] node story: " ns
   -- TODO reindex
   pure True
 

src/Gargantext/API/Ngrams/Tools.hs

@@ -14,22 +14,20 @@ Portability : POSIX
 module Gargantext.API.Ngrams.Tools
   where
 
-import Control.Concurrent
 import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
 import Control.Monad.Reader
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.Map.Strict qualified as Map
-import Data.Pool (withResource)
 import Data.Set qualified as Set
 import Data.Validity
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory
-import Gargantext.Core.NodeStoryFile qualified as NSF
-import Gargantext.Core.Types (ListType(..), NodeId, NodeType(..), ListId)
-import Gargantext.Database.Prelude (HasConnectionPool(..))
+-- import Gargantext.Core.NodeStoryFile qualified as NSF
+import Gargantext.Core.Types (ListType(..), NodeId, ListId)
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
+import GHC.Conc (TVar, readTVar)
 
 
 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
@@ -43,7 +41,7 @@ getRepo :: HasNodeStory env err m
 getRepo listIds = do
   f <- getNodeListStory
   v  <- liftBase $ f listIds
-  v' <- liftBase $ readMVar v
+  v' <- liftBase $ atomically $ readTVar v
   pure $ v'
 
 
@@ -58,7 +56,7 @@ repoSize repo node_id = Map.map Map.size state'
 
 
 getNodeStoryVar :: HasNodeStory env err m
-           => [ListId] -> m (MVar NodeListStory)
+           => [ListId] -> m (TVar NodeListStory)
 getNodeStoryVar l = do
   f <- getNodeListStory
   v  <- liftBase $ f l
@@ -66,7 +64,7 @@ getNodeStoryVar l = do
 
 
 getNodeListStory :: HasNodeStory env err m
-                 => m ([NodeId] -> IO (MVar NodeListStory))
+                 => m ([NodeId] -> IO (TVar NodeListStory))
 getNodeListStory = do
   env <- view hasNodeStory
   pure $ view nse_getter env
@@ -228,20 +226,20 @@ getCoocByNgrams'' (Diagonal diag) (f1,f2) (m1,m2) =
 ------------------------------------------
 
 
-migrateFromDirToDb :: (HasNodeStory env err m) -- , HasNodeStory env err m)
-                   => m ()
-migrateFromDirToDb = do
-  pool <- view connPool
-  withResource pool $ \c -> do
-    listIds <- liftBase $ getNodesIdWithType c NodeList
-    -- printDebug "[migrateFromDirToDb] listIds" listIds
-    (NodeStory nls) <- NSF.getRepoReadConfig listIds
-    -- printDebug "[migrateFromDirToDb] nls" nls
-    _ <- mapM (\(nId, a) -> do
-                  n <- liftBase $ nodeExists c nId
-                  case n of
-                    False -> pure ()
-                    True  -> liftBase $ upsertNodeStories c nId a
-              ) $ Map.toList nls
-    --_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
-    pure ()
+-- migrateFromDirToDb :: (HasNodeStory env err m) -- , HasNodeStory env err m)
+--                    => m ()
+-- migrateFromDirToDb = do
+--   pool <- view connPool
+--   withResource pool $ \c -> do
+--     listIds <- liftBase $ getNodesIdWithType c NodeList
+--     -- printDebug "[migrateFromDirToDb] listIds" listIds
+--     (NodeStory nls) <- NSF.getRepoReadConfig listIds
+--     -- printDebug "[migrateFromDirToDb] nls" nls
+--     _ <- mapM (\(nId, a) -> do
+--                   n <- liftBase $ nodeExists c nId
+--                   case n of
+--                     False -> pure ()
+--                     True  -> liftBase $ upsertNodeStories c nId a
+--               ) $ Map.toList nls
+--     --_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
+--     pure ()

src/Gargantext/Core/NodeStory.hs

@@ -82,7 +82,7 @@ module Gargantext.Core.NodeStory
   , runPGSAdvisoryUnlock
   , runPGSAdvisoryXactLock
   , getNodesIdWithType
-  , readNodeStoryEnv
+  , fromDBNodeStoryEnv
   , upsertNodeStories
   , getNodeStory
   , nodeStoriesQuery
@@ -93,7 +93,7 @@ module Gargantext.Core.NodeStory
 where
 
 import Codec.Serialise.Class
-import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
+-- import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
 import Control.Exception (throw)
 import Control.Lens (makeLenses, Getter, (^.), (.~), (%~), _Just, at, view)
 import Control.Monad.Except
@@ -122,16 +122,17 @@ import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
+import GHC.Conc (TVar, newTVar, readTVar, writeTVar)
 import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
 import qualified Database.PostgreSQL.Simple.ToField     as PGS
 
 ------------------------------------------------------------------------
 data NodeStoryEnv = NodeStoryEnv
-  { _nse_var    :: !(MVar NodeListStory)
+  { _nse_var    :: !(TVar NodeListStory)
   , _nse_saver  :: !(IO ())
   , _nse_saver_immediate :: !(IO ())
   , _nse_archive_saver_immediate :: !(NodeListStory -> IO NodeListStory)
-  , _nse_getter :: !([NodeId] -> IO (MVar NodeListStory))
+  , _nse_getter :: !([NodeId] -> IO (TVar 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)
   }
@@ -149,7 +150,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 (TVar NodeListStory))
 
 class HasNodeStorySaver env where
   hasNodeStorySaver :: Getter env (IO ())
@@ -167,7 +168,7 @@ class HasNodeArchiveStoryImmediateSaver env where
   is implemented already
 -}
 newtype NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
-  deriving (Generic, Show)
+  deriving (Generic, Show, Eq)
 
 instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
 instance (ToJSON s, ToJSON p) => ToJSON (NodeStory s p)
@@ -187,7 +188,7 @@ data Archive s p = Archive
     -- structure holds only recent history, the one that will be
     -- inserted to the DB.
   }
-  deriving (Generic, Show)
+  deriving (Generic, Show, Eq)
 
 instance (Serialise s, Serialise p) => Serialise (Archive s p)
 
@@ -300,6 +301,16 @@ runPGSExecuteMany c qs a = catch (PGS.executeMany c qs a) printError
       _ <- panic $ Text.pack $ show e
       throw (SomeException e)
 
+runPGSReturning :: (PGS.ToRow q, PGS.FromRow r)
+                => PGS.Connection -> PGS.Query -> [q] -> IO [r]
+runPGSReturning c qs a = catch (PGS.returning c qs a) printError
+  where
+    printError (SomeException e) = do
+      --q' <- PGS.formatQuery c qs a
+      _ <- panic $ Text.pack $ show e
+      throw (SomeException e)
+
+
 runPGSQuery :: (PGS.FromRow r, PGS.ToRow q)
             => PGS.Connection -> PGS.Query -> q -> IO [r]
 runPGSQuery c q a = catch (PGS.query c q a) printError
@@ -455,23 +466,27 @@ archiveStateListFilterFromSet set =
 -- | This function inserts whole new node story and archive for given node_id.
 insertNodeStory :: PGS.Connection -> NodeId -> ArchiveList -> IO ()
 insertNodeStory c nId a = do
-  mapM_ (\(ngramsType, ngrams, ngramsRepoElement) -> do
-            termIdM <- runPGSQuery c ngramsIdQuery (PGS.Only ngrams) :: IO [PGS.Only Int64]
-            case headMay termIdM of
-              Nothing -> pure 0
-              Just (PGS.Only termId) -> runPGSExecuteMany c query [(PGS.toField nId, a ^. a_version, ngramsType, termId, ngramsRepoElement)]) $ archiveStateToList $ a ^. a_state
-             -- runInsert c $ insert ngramsType ngrams ngramsRepoElement) $ archiveStateToList _a_state
+  insertArchiveStateList c nId (a ^. a_version) (archiveStateToList $ a ^. a_state)
+  -- mapM_ (\(ngramsType, ngrams, ngramsRepoElement) -> do
+  --           [PGS.Only termId] <- runPGSReturning c qInsert [PGS.Only ngrams] :: IO [PGS.Only Int]
+  --           runPGSExecuteMany c query [(PGS.toField nId, a ^. a_version, ngramsType, termId, ngramsRepoElement)]) $ archiveStateToList $ a ^. a_state
+  --            -- runInsert c $ insert ngramsType ngrams ngramsRepoElement) $ archiveStateToList _a_state
 
-  where
-    -- https://stackoverflow.com/questions/39224438/postgresql-insert-if-foreign-key-exists
-    query :: PGS.Query
-    query = [sql| INSERT INTO node_stories(node_id, ngrams_type_id, ngrams_id, ngrams_repo_element)
-                SELECT * FROM (
-                  VALUES (?, ?, ?, ?)
-                ) AS i(node_id, ngrams_type_id, ngrams_id, ngrams_repo_element)
-                WHERE EXISTS (
-                  SELECT * FROM nodes where nodes.id = node_id
-                )|]
+  -- where
+  --   qInsert :: PGS.Query
+  --   qInsert = [sql|INSERT INTO ngrams (terms) VALUES (?)
+  --                 ON CONFLICT (terms) DO UPDATE SET terms = excluded.terms
+  --                 RETURNING id|]
+
+  --   -- https://stackoverflow.com/questions/39224438/postgresql-insert-if-foreign-key-exists
+  --   query :: PGS.Query
+  --   query = [sql| INSERT INTO node_stories(node_id, ngrams_type_id, ngrams_id, ngrams_repo_element)
+  --               SELECT * FROM (
+  --                 VALUES (?, ?, ?, ?)
+  --               ) AS i(node_id, ngrams_type_id, ngrams_id, ngrams_repo_element)
+  --               WHERE EXISTS (
+  --                 SELECT * FROM nodes where nodes.id = node_id
+  --               )|]
     -- insert ngramsType ngrams ngramsRepoElement =
     --   Insert { iTable      = nodeStoryTable
     --          , iRows       = [NodeStoryDB { node_id = sqlInt4 nId
@@ -485,12 +500,29 @@ insertNodeStory c nId a = do
 
 insertArchiveStateList :: PGS.Connection -> NodeId -> Version -> ArchiveStateList -> IO ()
 insertArchiveStateList c nodeId version as = do
-  mapM_ (\(nt, n, nre) -> runPGSExecute c query (nodeId, version, nt, nre, n)) as
+  mapM_ performInsert as
   where
+    performInsert (nt, n, nre) = do
+      _ <- tryInsertTerms n
+      _ <- case nre ^. nre_root of
+        Nothing -> pure []
+        Just r -> tryInsertTerms r
+      mapM_ tryInsertTerms $ nre ^. nre_children
+      runPGSExecute c query (nodeId, version, nt, nre, n)
+    
+    tryInsertTerms :: NgramsTerm -> IO [PGS.Only Int]
+    tryInsertTerms t = runPGSReturning c qInsert [PGS.Only t]
+    
+    qInsert :: PGS.Query
+    qInsert = [sql|INSERT INTO ngrams (terms) VALUES (?)
+                  ON CONFLICT (terms) DO UPDATE SET terms = excluded.terms
+                  RETURNING id|]
+    
     query :: PGS.Query
-    query = [sql| WITH s as (SELECT ? as sid, ? sversion, ? sngrams_type_id, ngrams.id as sngrams_id, ?::jsonb as srepo FROM ngrams WHERE terms = ?)
+    query = [sql| WITH s AS (SELECT ? AS sid, ? sversion, ? sngrams_type_id, ngrams.id as sngrams_id, ?::jsonb AS srepo FROM ngrams WHERE terms = ?)
                   INSERT INTO node_stories(node_id, version, ngrams_type_id, ngrams_id, ngrams_repo_element)
-                  SELECT s.sid, s.sversion, s.sngrams_type_id, s.sngrams_id, s.srepo from s s join nodes n on s.sid = n.id
+                  SELECT s.sid, s.sversion, s.sngrams_type_id, s.sngrams_id, s.srepo
+                  FROM s s JOIN nodes n ON s.sid = n.id
             |]
 
 deleteArchiveStateList :: PGS.Connection -> NodeId -> ArchiveStateList -> IO ()
@@ -499,7 +531,7 @@ deleteArchiveStateList c nodeId as = do
   where
     query :: PGS.Query
     query = [sql| DELETE FROM node_stories
-                    WHERE node_id = ? AND ngrams_type_id = ? AND ngrams_id IN (SELECT id FROM ngrams WHERE terms = ?) |]
+                WHERE node_id = ? AND ngrams_type_id = ? AND ngrams_id IN (SELECT id FROM ngrams WHERE terms = ?) |]
 
 updateArchiveStateList :: PGS.Connection -> NodeId -> Version -> ArchiveStateList -> IO ()
 updateArchiveStateList c nodeId version as = do
@@ -542,7 +574,7 @@ updateNodeStory c nodeId currentArchive newArchive = do
   -- printDebug "[updateNodeStory] updates" $ Text.unlines $ (Text.pack . show) <$> updates
 
   -- 2. Perform inserts/deletes/updates
-  --printDebug "[updateNodeStory] applying insert" ()
+  -- printDebug "[updateNodeStory] applying inserts" inserts
   insertArchiveStateList c nodeId (newArchive ^. a_version) inserts
   --printDebug "[updateNodeStory] insert applied" ()
     --TODO Use currentArchive ^. a_version in delete and report error
@@ -635,69 +667,71 @@ nodeStoryIncs c (Just nls) ns = foldM (\m n -> nodeStoryInc c (Just m) n) nls ns
 --       pure $ NodeStory ns'
 ------------------------------------
 
-readNodeStoryEnv :: Pool PGS.Connection -> IO NodeStoryEnv
-readNodeStoryEnv pool = do
-  mvar <- nodeStoryVar pool Nothing []
-  let saver_immediate = modifyMVar_ mvar $ \ns -> do
+fromDBNodeStoryEnv :: Pool PGS.Connection -> IO NodeStoryEnv
+fromDBNodeStoryEnv pool = do
+  tvar <- nodeStoryVar pool Nothing []
+  let saver_immediate = do
+        ns <- atomically $ readTVar tvar
         withResource pool $ \c -> do
           --printDebug "[mkNodeStorySaver] will call writeNodeStories, ns" ns
           writeNodeStories c ns
-          pure ns
+          pure ()
   let archive_saver_immediate ns@(NodeStory nls) = withResource pool $ \c -> do
         mapM_ (\(nId, a) -> do
                   insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
               ) $ Map.toList nls
         pure $ clearHistory ns
-  saver <- mkNodeStorySaver saver_immediate
+  -- saver <- mkNodeStorySaver saver_immediate
   -- let saver = modifyMVar_ mvar $ \mv -> do
   --       writeNodeStories pool mv
-  --       printDebug "[readNodeStoryEnv] saver" mv
+  --       printDebug "[fromDBNodeStoryEnv] saver" mv
   --       let mv' = clearHistory mv
-  --       printDebug "[readNodeStoryEnv] saver, cleared" mv'
+  --       printDebug "[fromDBNodeStoryEnv] saver, cleared" mv'
   --       pure mv'
-  pure $ NodeStoryEnv { _nse_var    = mvar
-                      , _nse_saver  = saver
+  pure $ NodeStoryEnv { _nse_var    = tvar
+                      , _nse_saver  = saver_immediate
                       , _nse_saver_immediate = saver_immediate
                       , _nse_archive_saver_immediate = archive_saver_immediate
-                      , _nse_getter = nodeStoryVar pool (Just mvar)
+                      , _nse_getter = nodeStoryVar pool (Just tvar)
                       }
 
 nodeStoryVar :: Pool PGS.Connection
-             -> Maybe (MVar NodeListStory)
+             -> Maybe (TVar NodeListStory)
              -> [NodeId]
-             -> IO (MVar NodeListStory)
+             -> IO (TVar NodeListStory)
 nodeStoryVar pool Nothing nIds = do
   state' <- withResource pool $ \c -> nodeStoryIncs c Nothing nIds
-  newMVar state'
-nodeStoryVar pool (Just mv) nIds = do
-  _ <- withResource pool
-      $ \c -> modifyMVar_ mv
-      $ \nsl -> nodeStoryIncs c (Just nsl) nIds
-  pure mv
+  atomically $ newTVar state'
+nodeStoryVar pool (Just tv) nIds = do
+  nls <- atomically $ readTVar tv
+  nls' <- withResource pool
+      $ \c -> nodeStoryIncs c (Just nls) nIds
+  _ <- atomically $ writeTVar tv nls'
+  pure tv
 
 -- Debounce is useful since it could delay the saving to some later
 -- time, asynchronously and we keep operating on memory only.
 -- mkNodeStorySaver :: Pool PGS.Connection -> MVar NodeListStory -> IO (IO ())
 -- mkNodeStorySaver pool mvns = do
-mkNodeStorySaver :: IO () -> IO (IO ())
-mkNodeStorySaver saver = mkDebounce settings
-  where
-    settings = defaultDebounceSettings
-               { debounceAction = saver
-                   -- do
-                   --   -- NOTE: Lock MVar first, then use resource pool.
-                   --   -- Otherwise we could wait for MVar, while
-                   --   -- blocking the pool connection.
-                   --   modifyMVar_ mvns $ \ns -> do
-                   --     withResource pool $ \c -> do
-                   --       --printDebug "[mkNodeStorySaver] will call writeNodeStories, ns" ns
-                   --       writeNodeStories c ns
-                   --       pure $ clearHistory ns
-                     --withMVar mvns (\ns -> printDebug "[mkNodeStorySaver] debounce nodestory" ns)
-               , debounceFreq = 1*minute
-               }
-    minute = 60*sec
-    sec = 10^(6 :: Int)
+-- mkNodeStorySaver :: IO () -> IO (IO ())
+-- mkNodeStorySaver saver = mkDebounce settings
+--   where
+--     settings = defaultDebounceSettings
+--                { debounceAction = saver
+--                    -- do
+--                    --   -- NOTE: Lock MVar first, then use resource pool.
+--                    --   -- Otherwise we could wait for MVar, while
+--                    --   -- blocking the pool connection.
+--                    --   modifyMVar_ mvns $ \ns -> do
+--                    --     withResource pool $ \c -> do
+--                    --       --printDebug "[mkNodeStorySaver] will call writeNodeStories, ns" ns
+--                    --       writeNodeStories c ns
+--                    --       pure $ clearHistory ns
+--                      --withMVar mvns (\ns -> printDebug "[mkNodeStorySaver] debounce nodestory" ns)
+--                , debounceFreq = 1*minute
+--                }
+--     minute = 60*sec
+--     sec = 10^(6 :: Int)
 
 clearHistory :: NodeListStory -> NodeListStory
 clearHistory (NodeStory ns) = NodeStory $ ns & (traverse . a_history) .~ emptyHistory

src/Gargantext/Core/NodeStoryFile.hs → src/Gargantext/Core/NodeStoryFile.hs.old

@@ -22,7 +22,7 @@ import Control.Lens (view)
 import Data.ByteString.Lazy qualified as DBL
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
-import Gargantext.Core.NodeStory hiding (readNodeStoryEnv)
+import Gargantext.Core.NodeStory hiding (fromDBNodeStoryEnv)
 import Gargantext.Core.Types (ListId, NodeId(..))
 import Gargantext.Database.Prelude (hasConfig)
 import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams

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

@@ -17,7 +17,6 @@ Portability : POSIX
 module Gargantext.Database.Action.Flow.List
     where
 
-import Control.Concurrent
 import Control.Lens ((^.), (+~), (%~), at, (.~), _Just)
 import Control.Monad.Reader
 import Data.List qualified as List
@@ -35,6 +34,7 @@ import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
 import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb,{- getCgramsId -})
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
 import Gargantext.Prelude hiding (toList)
+import GHC.Conc (readTVar, writeTVar)
 
 -- FLOW LIST
 -- 1. select specific terms of the corpus when compared with others langs
@@ -202,8 +202,10 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
       -- If valid the rest would be atomic and no merge is required.
       -}
       var <- getNodeStoryVar [listId]
-      liftBase $ modifyMVar_ var $ \r -> do
-        pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
-                 & unNodeStory . at listId . _Just . a_history %~ (p :)
-                 & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
+      liftBase $ atomically $ do
+        r <- readTVar var
+        writeTVar var $
+          r & unNodeStory . at listId . _Just . a_version +~ 1
+            & unNodeStory . at listId . _Just . a_history %~ (p :)
+            & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
       saveNodeStory

test/Test/API/Setup.hs

@@ -54,7 +54,7 @@ newTestEnv testEnv logger port = do
   dbParam        <- pure $ testEnvToPgConnectionInfo testEnv
   !pool          <- newPool dbParam
 
-  !nodeStory_env <- readNodeStoryEnv pool
+  !nodeStory_env <- fromDBNodeStoryEnv pool
   !scrapers_env  <- ServantAsync.newJobEnv ServantAsync.defaultSettings manager_env
 
   secret        <- Jobs.genSecret

test/Test/Database/Operations.hs

@@ -26,6 +26,7 @@ import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Prelude
 import Test.API.Setup (setupEnvironment)
 import Test.Database.Operations.DocumentSearch
+import Test.Database.Operations.NodeStory
 import Test.Database.Setup (withTestDB)
 import Test.Database.Types
 import Test.Hspec
@@ -63,6 +64,11 @@ tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
       it "Can perform search by author in documents" corpusSearch02
       it "Can perform more complex searches using the boolean API" corpusSearch03
       it "Can correctly count doc score" corpusScore01
+    describe "Node story" $ do
+      it "Can create a list" createListTest
+      it "Can add query node story" queryNodeStoryTest
+      it "Can add new terms to node story" insertNewTermsToNodeStoryTest
+      it "Can add new terms (with children) to node story" insertNewTermsWithChildrenToNodeStoryTest
 
 data ExpectedActual a =
     Expected a

test/Test/Database/Operations/NodeStory.hs

+{-|
+Module      : Test.Database.Operations.NodeStory
+Description : GarganText database tests
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+
+module Test.Database.Operations.NodeStory where
+
+import Control.Monad.Reader
+import Data.Map.Strict qualified as Map
+import Data.Set qualified as Set
+import Database.PostgreSQL.Simple qualified as PSQL
+import Database.PostgreSQL.Simple.SqlQQ
+import Gargantext.API.Ngrams (setListNgrams, saveNodeStoryImmediate)
+import Gargantext.API.Ngrams.Types (MSet(..), NgramsRepoElement(..), NgramsTerm(..))
+import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
+import Gargantext.Core.NodeStory hiding (runPGSQuery)
+import Gargantext.Core.Types.Individu
+import Gargantext.Core.Types (ListType(..))
+import Gargantext.Database.Action.User (getUserId)
+import Gargantext.Database.Admin.Config (userMaster)
+import Gargantext.Database.Prelude (runPGSQuery)
+import Gargantext.Database.Query.Table.Ngrams (selectNgramsId)
+import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Tree.Root
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
+import Gargantext.Database.Schema.Node (NodePoly(..))
+import Gargantext.Prelude
+import GHC.Conc (readTVar)
+import Test.Database.Types
+import Test.Hspec.Expectations
+import Test.Tasty.HUnit
+
+
+
+createListTest :: TestEnv -> Assertion
+createListTest env = do
+  flip runReaderT env $ runTestMonad $ do
+    -- NOTE(adn) We need to create user 'gargantua'(!!) in order
+    -- for 'addDocumentsToHyperCorpus' to work.
+    let user = UserName userMaster
+    parentId <- getRootId user
+    [corpus] <- getCorporaWithParentId parentId
+    let corpusId = _node_id corpus
+
+    userId <- getUserId user
+
+    listId <- getOrMkList corpusId userId
+    listId' <- getOrMkList corpusId userId
+    
+    liftIO $ listId `shouldBe` listId'
+
+
+queryNodeStoryTest :: TestEnv -> Assertion
+queryNodeStoryTest env = do
+  flip runReaderT env $ runTestMonad $ do
+    -- NOTE(adn) We need to create user 'gargantua'(!!) in order
+    -- for 'addDocumentsToHyperCorpus' to work.
+    let user = UserName userMaster
+    parentId <- getRootId user
+    [corpus] <- getCorporaWithParentId parentId
+    let corpusId = _node_id corpus
+
+    userId <- getUserId user
+
+    listId <- getOrMkList corpusId userId
+
+    saveNodeStoryImmediate
+
+    v <- getNodeStoryVar [listId]
+    
+    liftIO $ do
+      ns <- atomically $ readTVar v
+      ns `shouldBe` (NodeStory $ Map.singleton listId $ Archive { _a_version = 0
+                                                                , _a_state = Map.empty
+                                                                , _a_history = [] })
+  
+
+insertNewTermsToNodeStoryTest :: TestEnv -> Assertion
+insertNewTermsToNodeStoryTest env = do
+  flip runReaderT env $ runTestMonad $ do
+    -- NOTE(adn) We need to create user 'gargantua'(!!) in order
+    -- for 'addDocumentsToHyperCorpus' to work.
+    let user = UserName userMaster
+    parentId <- getRootId user
+    [corpus] <- getCorporaWithParentId parentId
+    let corpusId = _node_id corpus
+
+    userId <- getUserId user
+
+    listId <- getOrMkList corpusId userId
+
+    v <- getNodeStoryVar [listId]
+
+    let nre = NgramsRepoElement { _nre_size = 1
+                                , _nre_list = MapTerm
+                                , _nre_root = Nothing
+                                , _nre_parent = Nothing
+                                , _nre_children =  MSet Map.empty }
+    let terms = "hello"
+    let nls = Map.singleton (NgramsTerm terms) nre
+    setListNgrams listId NgramsTerms nls
+    
+    liftIO $ do
+      ns <- atomically $ readTVar v
+      ns `shouldBe` (NodeStory $ Map.singleton listId $ Archive { _a_version = 0
+                                                                , _a_state = Map.singleton NgramsTerms nls
+                                                                , _a_history = [] })
+    -- check that the ngrams are in the DB as well
+    ngramsMap <- selectNgramsId [terms]
+    -- saveNodeStory is called by `setListNgrams`
+    liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` [terms]
+    
+    -- _ <- insertNgrams [UnsafeNgrams { _ngramsTerms = terms
+    --                                 , _ngramsSize = 1 }]
+
+    -- Finally, check that node stories are inserted correctly
+    -- saveNodeStoryImmediate
+
+    dbTerms <- runPGSQuery [sql|
+                               SELECT terms
+                               FROM ngrams
+                               JOIN node_stories ON ngrams.id = ngrams_id
+                               WHERE node_id = ?
+                               |] (PSQL.Only listId)
+    liftIO $ dbTerms `shouldBe` [PSQL.Only terms]
+                           
+
+insertNewTermsWithChildrenToNodeStoryTest :: TestEnv -> Assertion
+insertNewTermsWithChildrenToNodeStoryTest env = do
+  flip runReaderT env $ runTestMonad $ do
+    -- NOTE(adn) We need to create user 'gargantua'(!!) in order
+    -- for 'addDocumentsToHyperCorpus' to work.
+    let user = UserName userMaster
+    parentId <- getRootId user
+    [corpus] <- getCorporaWithParentId parentId
+    let corpusId = _node_id corpus
+
+    userId <- getUserId user
+
+    listId <- getOrMkList corpusId userId
+
+    v <- getNodeStoryVar [listId]
+
+    let tParent = NgramsTerm "hello"
+    let tChild = NgramsTerm "world"
+    let terms = unNgramsTerm <$> [tParent, tChild]
+    let nreParent = NgramsRepoElement { _nre_size = 1
+                                      , _nre_list = MapTerm
+                                      , _nre_root = Nothing
+                                      , _nre_parent = Nothing
+                                      , _nre_children = MSet $ Map.singleton tChild () }
+    let nreChild = NgramsRepoElement { _nre_size = 1
+                                     , _nre_list = MapTerm
+                                     , _nre_root = Nothing
+                                     , _nre_parent = Just tParent
+                                     , _nre_children = MSet Map.empty }
+    
+    let nls = Map.fromList [(tParent, nreParent), (tChild, nreChild)]
+    setListNgrams listId NgramsTerms nls
+
+    liftIO $ do
+      ns <- atomically $ readTVar v
+      ns `shouldBe` (NodeStory $ Map.singleton listId $ Archive { _a_version = 0
+                                                                , _a_state = Map.singleton NgramsTerms nls
+                                                                , _a_history = [] })
+
+    -- `setListNgrams` calls saveNodeStory already so we should have
+    -- the terms in the DB by now
+    ngramsMap <- selectNgramsId terms
+    liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` terms
+    
+    saveNodeStoryImmediate
+    dbTerms <- runPGSQuery [sql|
+                               SELECT terms
+                               FROM ngrams
+                               JOIN node_stories ON ngrams.id = ngrams_id
+                               WHERE node_id = ?
+                               |] (PSQL.Only listId)
+    liftIO $ (Set.fromList $ (\(PSQL.Only t) -> t) <$> dbTerms) `shouldBe` (Set.fromList terms)
+
+    ngramsMap2 <- selectNgramsId terms
+    liftIO $ (Set.fromList (snd <$> Map.toList ngramsMap2)) `shouldBe` (Set.fromList terms)
+
+    -- let (Just (tParentId, _)) = head $ filter ((==) (unNgramsTerm tParent) . snd) $ Map.toList ngramsMap2
+    -- let (Just (tChildId, _)) = head $ filter ((==) (unNgramsTerm tChild) . snd) $ Map.toList ngramsMap2
+                           
+    -- [PSQL.Only tParentId'] <-
+    --   runPGSQuery [sql|SELECT parent_id FROM ngrams WHERE terms = ?|] (PSQL.Only tChild)
+
+    -- liftIO $ tParentId `shouldBe` tParentId'
+

test/Test/Database/Setup.hs

@@ -15,6 +15,7 @@ import Database.PostgreSQL.Simple.Options qualified as Client
 import Database.PostgreSQL.Simple.Options qualified as Opts
 import Database.Postgres.Temp qualified as Tmp
 import Gargantext.API.Admin.EnvTypes (Mode(Mock))
+import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config
 import Gargantext.System.Logging (withLoggerHoisted)
@@ -71,8 +72,13 @@ setup = do
                          (PG.close) 2 60 2
       bootstrapDB db pool gargConfig
       ugen <- emptyCounter
+      test_nodeStory <- fromDBNodeStoryEnv pool
       withLoggerHoisted Mock $ \logger -> do
-        pure $ TestEnv (DBHandle pool db) gargConfig ugen logger
+        pure $ TestEnv { test_db = DBHandle pool db
+                       , test_config = gargConfig
+                       , test_nodeStory
+                       , test_usernameGen = ugen
+                       , test_logger = logger }
 
 withTestDB :: (TestEnv -> IO ()) -> IO ()
 withTestDB = bracket setup teardown

test/Test/Database/Types.hs

@@ -32,6 +32,7 @@ import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Prelude
 import Gargantext.Core.Mail.Types (HasMail(..))
 import Gargantext.Core.NLP (HasNLPServer(..))
+import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude (HasConfig(..), HasConnectionPool(..))
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Prelude.Config
@@ -57,6 +58,7 @@ nextCounter (Counter ref) = atomicModifyIORef' ref (\old -> (succ old, old))
 data TestEnv = TestEnv {
     test_db                  :: !DBHandle
   , test_config              :: !GargConfig
+  , test_nodeStory           :: !NodeStoryEnv
   , test_usernameGen         :: !Counter
   , test_logger              :: !(Logger (GargM TestEnv GargError))
   }
@@ -107,6 +109,23 @@ instance HasMail TestEnv where
                                         , _mc_mail_password   = "test"
                                         , _mc_mail_login_type = NoAuth })
 
+instance HasNodeStoryEnv TestEnv where
+  hasNodeStory = to test_nodeStory
+
+
+instance HasNodeStoryVar TestEnv where
+  hasNodeStoryVar = hasNodeStory . nse_getter
+
+instance HasNodeStorySaver TestEnv where
+  hasNodeStorySaver = hasNodeStory . nse_saver
+
+instance HasNodeStoryImmediateSaver TestEnv where
+  hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
+
+instance HasNodeArchiveStoryImmediateSaver TestEnv where
+  hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
+
+
 coreNLPConfig :: NLPServerConfig
 coreNLPConfig =
   let uri = parseURI "http://localhost:9000"