Merge remote-tracking branch 'origin/281-dev-ngrams-fixes' into dev

gargantext.cabal

@@ -130,6 +130,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
@@ -216,7 +217,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/EnvTypes.hs

@@ -138,9 +138,6 @@ instance HasNodeStoryEnv Env where
 instance HasNodeStoryVar Env where
   hasNodeStoryVar = hasNodeStory . nse_getter
 
-instance HasNodeStorySaver Env where
-  hasNodeStorySaver = hasNodeStory . nse_saver
-
 instance HasNodeStoryImmediateSaver Env where
   hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
 
@@ -310,9 +307,6 @@ instance HasNodeStoryEnv DevEnv where
 instance HasNodeStoryVar DevEnv where
   hasNodeStoryVar = hasNodeStory . nse_getter
 
-instance HasNodeStorySaver DevEnv where
-  hasNodeStorySaver = hasNodeStory . nse_saver
-
 instance HasNodeStoryImmediateSaver DevEnv where
   hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
 

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,8 +87,7 @@ module Gargantext.API.Ngrams
   )
   where
 
-import Control.Concurrent
-import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), msumOf, at, _Just, Each(..), (%%~), mapped, ifolded, to, withIndex, over)
+import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), msumOf, at, _Just, Each(..), (%%~), mapped, non, ifolded, to, withIndex, over)
 import Control.Monad.Reader
 import Data.Aeson.Text qualified as DAT
 import Data.Foldable
@@ -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)
 
@@ -173,10 +173,10 @@ mkChildrenGroups addOrRem nt patches =
 
 ------------------------------------------------------------------------
 
-saveNodeStory :: ( MonadReader env m, MonadBase IO m, HasNodeStorySaver env )
+saveNodeStory :: ( MonadReader env m, MonadBase IO m, HasNodeStoryImmediateSaver env )
               => m ()
 saveNodeStory = do
-  saver <- view hasNodeStorySaver
+  saver <- view hasNodeStoryImmediateSaver
   liftBase $ do
     --Gargantext.Prelude.putStrLn "---- Running node story saver ----"
     saver
@@ -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,18 @@ 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
+        %~ (\mns' -> case mns' of
+               Nothing -> Just ns
+               Just ns' -> Just $ ns <> ns')
+      ) nls
   saveNodeStory
 
 
@@ -292,57 +294,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 . non initArchive
+    -- 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 +362,7 @@ commitStatePatch listId (Versioned _p_version p) = do
   -- saveNodeStory
   saveNodeStoryImmediate
 
-  pure vq'
+  pure $ snd newNs
 
 
 
@@ -363,10 +375,10 @@ 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
+    a = r ^. unNodeStory . at listId . non initArchive
     q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
     q_table = q ^. _PatchMap . at ngramsType . _Just
 
@@ -491,7 +503,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

@@ -122,7 +122,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/API/Ngrams/Types.hs

@@ -147,7 +147,9 @@ makeLenses ''RootParent
 data NgramsRepoElement = NgramsRepoElement
   { _nre_size        :: !Int
   , _nre_list        :: !ListType
+  -- root is the top-most parent of ngrams
   , _nre_root        :: !(Maybe NgramsTerm)
+  -- parent is the direct parent of this ngram
   , _nre_parent      :: !(Maybe NgramsTerm)
   , _nre_children    :: !(MSet NgramsTerm)
   }

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

 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings    #-}
 
 module Test.API.Setup where
 
@@ -21,6 +22,7 @@ import Gargantext.Database.Admin.Trigger.Init
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getOrMkList)
+-- import Gargantext.Prelude (printDebug)
 import Gargantext.Prelude.Config
 import Gargantext.System.Logging
 import Network.HTTP.Client.TLS (newTlsManager)
@@ -54,7 +56,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
@@ -101,6 +103,7 @@ setupEnvironment env = flip runReaderT env $ runTestMonad $ do
                                         (Left corpusMasterName)
                                         (Nothing :: Maybe HyperdataCorpus)
   masterListId <- getOrMkList masterCorpusId masterUserId
+  -- printDebug "[setupEnvironment] masterListId: " masterListId
   void $ initLastTriggers masterListId
 
 -- | Creates two users, Alice & Bob. Alice shouldn't be able to see

test/Test/Database/Operations.hs

 {-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TupleSections        #-}
 {-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -6,13 +7,15 @@
 {-# OPTIONS_GHC -Wno-orphans      #-}
 
 module Test.Database.Operations (
-   tests
+     tests
+   , nodeStoryTests
   ) where
 
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Text qualified as T
 import Database.PostgreSQL.Simple
+import Database.PostgreSQL.Simple.SqlQQ
 import Gargantext.API.Node.Corpus.Update
 import Gargantext.Core
 import Gargantext.Core.Types.Individu
@@ -20,12 +23,14 @@ import Gargantext.Database.Action.User
 import Gargantext.Database.Action.User.New
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude (runPGSQuery)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Tree.Root (getRootId)
 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,7 +68,26 @@ 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
-
+        
+nodeStoryTests :: Spec
+nodeStoryTests = sequential $
+  -- run 'withTestDB' before _every_ test item
+  around setupDBAndCorpus $
+  describe "Database - node story" $ do
+    describe "Node story" $ do
+      it "[#281] Can create a list" createListTest
+      it "[#281] Can query node story" queryNodeStoryTest
+      it "[#218] Can add new terms to node story" insertNewTermsToNodeStoryTest
+      it "[#281] Can add new terms (with children) to node story" insertNewTermsWithChildrenToNodeStoryTest
+      it "[#281] Fixes child terms to match parents' terms" insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest
+      it "[#281] Can update node story when 'setListNgrams' is called" setListNgramsUpdatesNodeStoryTest
+      it "[#281] When 'setListNgrams' is called, childrens' parents are updated" setListNgramsUpdatesNodeStoryWithChildrenTest
+      it "[#281] Correctly commits patches to node story - simple" commitPatchSimpleTest
+  where
+    setupDBAndCorpus testsFunc = withTestDB $ \env -> do
+      setupEnvironment env
+      testsFunc env
+  
 data ExpectedActual a =
     Expected a
   | Actual a
@@ -126,8 +150,10 @@ corpusReadWrite01 env = do
   flip runReaderT env $ runTestMonad $ do
     uid      <- getUserId (UserName "alfredo")
     parentId <- getRootId (UserName "alfredo")
-    [corpusId] <- mk (Just "Test_Corpus") (Nothing :: Maybe HyperdataCorpus) parentId uid
-    liftIO $ corpusId `shouldBe` UnsafeMkNodeId 416
+    let corpusName = "Test_Corpus"
+    [corpusId] <- mk (Just corpusName) (Nothing :: Maybe HyperdataCorpus) parentId uid
+    [Only corpusId'] <- runPGSQuery [sql|SELECT id FROM nodes WHERE name = ?|] (Only corpusName)
+    liftIO $ corpusId `shouldBe` UnsafeMkNodeId corpusId'
     -- Retrieve the corpus by Id
     [corpus] <- getCorporaWithParentId parentId
     liftIO $ corpusId `shouldBe` (_node_id corpus)

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,20 @@ 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 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"

test/Test/Ngrams/Query.hs

@@ -2,19 +2,18 @@
 {-# LANGUAGE TypeApplications #-}
 module Test.Ngrams.Query (tests) where
 
-import           Control.Monad
-import           Data.Coerce
-import           Data.Monoid
-import           Gargantext.API.Ngrams
-import           Gargantext.API.Ngrams.Types
-import           Gargantext.Core.Types.Main
-import           Gargantext.Core.Types.Query
-import           Gargantext.Prelude
-import qualified Data.Map.Strict as Map
-import qualified Data.Patch.Class as Patch
-import qualified Data.Validity    as Validity
-import qualified Data.Text as T
-
+import Control.Monad
+import Data.Coerce
+import Data.Map.Strict qualified as Map
+import Data.Monoid
+import Data.Patch.Class qualified as Patch
+import Data.Text qualified as T
+import Data.Validity qualified as Validity
+import Gargantext.API.Ngrams
+import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Types.Main
+import Gargantext.Core.Types.Query
+import Gargantext.Prelude
 import Test.Ngrams.Query.PaginationCorpus
 import Test.Tasty
 import Test.Tasty.HUnit

test/drivers/hspec/Main.hs

@@ -43,3 +43,4 @@ main = do
   bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do
     API.tests
     DB.tests
+    DB.nodeStoryTests