[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/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"