[FIX] merge

README.md

@@ -72,6 +72,52 @@ This will take a bit of time as it has to download/build the dependencies, but t
 
 #### With Cabal (recommanded)
 
+##### Turning off optimization flags
+
+Create a `cabal.project.local` file (don't commit it to git!):
+```
+package gargantext
+    ghc-options: -fwrite-ide-info -hiedir=".stack-work/hiedb" -O0
+
+package gargantext-admin
+    ghc-options: -O0
+
+package gargantext-cli
+    ghc-options: -O0
+
+package gargantext-db-obfuscation
+    ghc-options: -O0
+
+package gargantext-import
+    ghc-options: -O0
+
+package gargantext-init
+    ghc-options: -O0
+
+package gargantext-invitations
+    ghc-options: -O0
+
+package gargantext-phylo
+    ghc-options: -O0
+
+package gargantext-server
+    ghc-options: -O0
+
+package gargantext-upgrade
+    ghc-options: -O0
+
+package gargantext-graph
+    ghc-options: -O0
+
+package hmatrix
+    ghc-options: -O0
+
+package sparse-linear
+    ghc-options: -O0
+```
+
+##### Building
+
 First, into `nix-shell`:
 ```shell
 cabal update

bin/update-project-dependencies

@@ -18,7 +18,7 @@ fi
 # with the `sha256sum` result calculated on the `cabal.project` and
 # `cabal.project.freeze`. This ensures the files stay deterministic so that CI
 # cache can kick in.
-expected_cabal_project_hash="3f5d6b7f26cac4aa5a7f87ba0227a7671041dfe46643ddef79512eb49bd876ec"
+expected_cabal_project_hash="c9fe39301e8b60bfd183e60e7e25a14cd1c9c66d8739bf9041ca3f4db89db7c6"
 expected_cabal_project_freeze_hash="db24c7d3006167102532e3101e2b49bae13d478003459c7d3f1d66590e57740a"
 
 cabal --store-dir=$STORE_DIR v2-build --dry-run

cabal.project

@@ -31,8 +31,8 @@ source-repository-package
 
 source-repository-package
     type: git
-    location: https://github.com/adinapoli/haskell-opaleye.git
-    tag: e9a29582ac66198dd2c2fdc3f8c8a4b1e6fbe004
+    location: https://github.com/garganscript/haskell-opaleye.git
+    tag: 6cf1bcfe215143efac17919cfd0abdd60e0f717c
 
 source-repository-package
     type: git
@@ -183,12 +183,9 @@ allow-newer: *
 
 package gargantext
     ghc-options: -fwrite-ide-info -hiedir=".stack-work/hiedb"
-
-package gargantext-graph
-    ghc-options: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal  -fno-state-hack
-
+    
 package hmatrix
-    ghc-options: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal  -fno-state-hack
+    ghc-options: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal -fno-state-hack
 
 package sparse-linear
-    ghc-options: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal  -fno-state-hack
+    ghc-options: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal -fno-state-hack

src/Gargantext/API.hs

@@ -48,10 +48,8 @@ import Gargantext.API.Admin.Settings.CORS
 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings)
 import Gargantext.API.EKG
 import Gargantext.API.Middleware (logStdoutDevSanitised)
-import Gargantext.API.Ngrams (saveNodeStoryImmediate)
 import Gargantext.API.Routes
 import Gargantext.API.Server (server)
-import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude qualified as DB
 import Gargantext.Prelude hiding (putStrLn)
 import Gargantext.System.Logging
@@ -74,7 +72,7 @@ startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
   app <- makeApp env
   mid <- makeGargMiddleware (env ^. settings.corsSettings) mode
   periodicActions <- schedulePeriodicActions env
-  run port (mid app) `finally` stopGargantext env periodicActions
+  run port (mid app) `finally` stopGargantext periodicActions
 
   where runDbCheck env = do
           r <- runExceptT (runReaderT DB.dbCheck env) `catch`
@@ -94,11 +92,10 @@ portRouteInfo port = do
 -- | Stops the gargantext server and cancels all the periodic actions
 -- scheduled to run up to that point.
 -- TODO clean this Monad condition (more generic) ?
-stopGargantext :: HasNodeStoryImmediateSaver env => env -> [ThreadId] -> IO ()
-stopGargantext env scheduledPeriodicActions = do
+stopGargantext :: [ThreadId] -> IO ()
+stopGargantext scheduledPeriodicActions = do
   forM_ scheduledPeriodicActions killThread
   putStrLn "----- Stopping gargantext -----"
-  runReaderT saveNodeStoryImmediate env
 
 -- | Schedules all sorts of useful periodic actions to be run while
 -- the server is alive accepting requests.

src/Gargantext/API/Admin/EnvTypes.hs

@@ -136,9 +136,6 @@ instance HasConnectionPool Env where
 instance HasNodeStoryEnv Env where
   hasNodeStory = env_nodeStory
 
-instance HasNodeStoryVar Env where
-  hasNodeStoryVar = hasNodeStory . nse_getter
-
 instance HasNodeStoryImmediateSaver Env where
   hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
 
@@ -314,9 +311,6 @@ instance HasSettings DevEnv where
 instance HasNodeStoryEnv DevEnv where
   hasNodeStory = dev_env_nodeStory
 
-instance HasNodeStoryVar DevEnv where
-  hasNodeStoryVar = hasNodeStory . nse_getter
-
 instance HasNodeStoryImmediateSaver DevEnv where
   hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
 

src/Gargantext/API/Dev.hs

@@ -16,7 +16,6 @@ import Control.Monad (fail)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Settings
 import Gargantext.API.Errors.Types
-import Gargantext.API.Ngrams (saveNodeStoryImmediate)
 import Gargantext.API.Prelude
 import Gargantext.Core.NLP (nlpServerMap)
 import Gargantext.Core.NodeStory
@@ -72,9 +71,7 @@ runCmdDev env f =
 
 runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a
 runCmdGargDev env cmd =
-  (either (fail . show) pure =<< runExceptT (runReaderT cmd env))
-    `finally`
-  runReaderT saveNodeStoryImmediate env
+  either (fail . show) pure =<< runExceptT (runReaderT cmd env)
 
 runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
 runCmdDevNoErr = runCmdDev

src/Gargantext/API/Ngrams.hs

@@ -60,7 +60,6 @@ module Gargantext.API.Ngrams
   , r_history
   , NgramsRepoElement(..)
   , saveNodeStory
-  , saveNodeStoryImmediate
   , initRepo
 
   , TabType(..)
@@ -87,7 +86,7 @@ module Gargantext.API.Ngrams
   )
   where
 
-import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), msumOf, at, _Just, Each(..), (%%~), mapped, non, ifolded, to, withIndex, over)
+import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), msumOf, at, _Just, Each(..), (%%~), mapped, ifolded, to, withIndex, over)
 import Control.Monad.Reader
 import Data.Aeson.Text qualified as DAT
 import Data.Foldable
@@ -105,10 +104,10 @@ import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.Errors.Types
 import Gargantext.API.Metrics qualified as Metrics
-import Gargantext.API.Ngrams.Tools
+import Gargantext.API.Ngrams.Tools (getNodeStory)
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Prelude
-import Gargantext.Core.NodeStory
+import Gargantext.Core.NodeStory (ArchiveList, HasNodeStory, HasNodeArchiveStoryImmediateSaver(..), HasNodeStoryImmediateSaver(..), NgramsStatePatch', a_history, a_state, a_version, currentVersion)
 import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, TODO, assertValid, HasValidationError, ContextId)
 import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
 import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast)
@@ -123,7 +122,6 @@ import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
 import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
 import Gargantext.Prelude.Clock (hasTime, getTime)
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
-import GHC.Conc (readTVar, writeTVar)
 import Servant hiding (Patch)
 
 {-
@@ -174,23 +172,10 @@ mkChildrenGroups addOrRem nt patches =
 ------------------------------------------------------------------------
 
 saveNodeStory :: ( MonadReader env m, MonadBase IO m, HasNodeStoryImmediateSaver env )
-              => m ()
-saveNodeStory = do
+              => NodeId -> ArchiveList -> m ()
+saveNodeStory nId a = do
   saver <- view hasNodeStoryImmediateSaver
-  liftBase $ do
-    --Gargantext.Prelude.putStrLn "---- Running node story saver ----"
-    saver
-    --Gargantext.Prelude.putStrLn "---- Node story saver finished ----"
-
-
-saveNodeStoryImmediate :: ( MonadReader env m, MonadBase IO m, HasNodeStoryImmediateSaver env )
-                       => m ()
-saveNodeStoryImmediate = do
-  saver <- view hasNodeStoryImmediateSaver
-  liftBase $ do
-    --Gargantext.Prelude.putStrLn "---- Running node story immediate saver ----"
-    saver
-    --Gargantext.Prelude.putStrLn "---- Node story immediate saver finished ----"
+  liftBase $ saver nId a
 
 listTypeConflictResolution :: ListType -> ListType -> ListType
 listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
@@ -256,19 +241,23 @@ setListNgrams :: HasNodeStory env err m
               -> m ()
 setListNgrams listId ngramsType ns = do
   -- printDebug "[setListNgrams]" (listId, ngramsType)
-  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
+  a <- getNodeStory listId
+  let a' = a & a_state . at ngramsType %~ (\mns' -> case mns' of
+                                              Nothing -> Just ns
+                                              Just ns' -> Just $ ns <> ns')
+  saveNodeStory listId a'
+  -- 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
 
 
 newNgramsFromNgramsStatePatch :: NgramsStatePatch' -> [Ngrams]
@@ -292,11 +281,11 @@ commitStatePatch :: ( HasNodeStory env err m
                  -> m (Versioned NgramsStatePatch')
 commitStatePatch listId (Versioned _p_version p) = do
   -- printDebug "[commitStatePatch]" listId
-  var <- getNodeStoryVar [listId]
+  a <- getNodeStory listId
   archiveSaver <- view hasNodeArchiveStoryImmediateSaver
-  ns <- liftBase $ atomically $ readTVar var
+  -- ns <- liftBase $ atomically $ readTVar var
   let
-    a = ns ^. unNodeStory . at listId . non initArchive
+    -- 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)
@@ -327,10 +316,12 @@ commitStatePatch listId (Versioned _p_version p) = do
   -}
   -- 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'
-       )
+  -- let newNs = ( ns & unNodeStory . at listId .~ (Just a')
+  --      , Versioned (a' ^. a_version) q'
+  --      )
 
+  let newA = 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
@@ -353,16 +344,15 @@ commitStatePatch listId (Versioned _p_version p) = do
   -- archive was saved and applied)
   -- newNs' <- archiveSaver $ fst newNs
   liftBase $ do
-    newNs' <- archiveSaver $ fst newNs
-    atomically $ writeTVar var newNs'
+    -- newNs' <- archiveSaver $ fst newNs
+    -- atomically $ writeTVar var newNs'
+    void $ archiveSaver listId a'
 
   -- Save new ngrams
   _ <- insertNgrams (newNgramsFromNgramsStatePatch p)
-  -- NOTE State (i.e. `NodeStory` can be saved asynchronously, i.e. with debounce)
-  -- saveNodeStory
-  saveNodeStoryImmediate
+  saveNodeStory listId a'
 
-  pure $ snd newNs
+  pure newA
 
 
 
@@ -374,11 +364,11 @@ tableNgramsPull :: HasNodeStory env err m
                 -> m (Versioned NgramsTablePatch)
 tableNgramsPull listId ngramsType p_version = do
   -- printDebug "[tableNgramsPull]" (listId, ngramsType)
-  var <- getNodeStoryVar [listId]
-  r <- liftBase $ atomically $ readTVar var
+  a <- getNodeStory listId
+  -- r <- liftBase $ atomically $ readTVar var
 
   let
-    a = r ^. unNodeStory . at listId . non initArchive
+    -- 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
 
@@ -502,10 +492,9 @@ getNgramsTableMap :: HasNodeStory env err m
                   -> TableNgrams.NgramsType
                   -> m (Versioned NgramsTableMap)
 getNgramsTableMap nodeId ngramsType = do
-  v    <- getNodeStoryVar [nodeId]
-  repo <- liftBase $ atomically $ readTVar v
-  pure $ Versioned (repo ^. unNodeStory . at nodeId . _Just . a_version)
-                   (repo ^. unNodeStory . at nodeId . _Just . a_state . at ngramsType . _Just)
+  a <- getNodeStory nodeId
+  pure $ Versioned (a ^. a_version)
+                   (a ^. a_state . at ngramsType . _Just)
 
 
 dumpJsonTableMap :: HasNodeStory env err m

src/Gargantext/API/Ngrams/Tools.hs

@@ -23,7 +23,7 @@ import Data.HashMap.Strict qualified as HM
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
 import Data.Validity
-import GHC.Conc (TVar, readTVar)
+-- import GHC.Conc (TVar, readTVar)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Types (ListType(..), NodeId, ListId)
@@ -40,10 +40,11 @@ type RootTerm = NgramsTerm
 getRepo :: HasNodeStory env err m
          => [ListId] -> m NodeListStory
 getRepo listIds = do
-  f <- getNodeListStory
-  v  <- liftBase $ f listIds
-  v' <- liftBase $ atomically $ readTVar v
-  pure $ v'
+  f <- getNodeListStoryMulti
+  liftBase $ f listIds
+  -- v  <- liftBase $ f listIds
+  -- v' <- liftBase $ atomically $ readTVar v
+  -- pure $ v'
 
 
 repoSize :: Ord k1 => NodeStory (Map.Map k1 (Map.Map k2 a)) p
@@ -56,21 +57,29 @@ repoSize repo node_id = Map.map Map.size state'
                    . a_state
 
 
-getNodeStoryVar :: HasNodeStory env err m
-           => [ListId] -> m (TVar NodeListStory)
-getNodeStoryVar l = do
+getNodeStory :: HasNodeStory env err m
+           => ListId -> m ArchiveList
+getNodeStory l = do
   f <- getNodeListStory
-  v  <- liftBase $ f l
-  pure v
+  liftBase $ f l
+  -- v  <- liftBase $ f l
+  -- pure v
 
 
 getNodeListStory :: HasNodeStory env err m
-                 => m ([NodeId] -> IO (TVar NodeListStory))
+                 => m (NodeId -> IO ArchiveList)
 getNodeListStory = do
   env <- view hasNodeStory
   pure $ view nse_getter env
 
 
+getNodeListStoryMulti :: HasNodeStory env err m
+                      => m ([NodeId] -> IO NodeListStory)
+getNodeListStoryMulti = do
+  env <- view hasNodeStory
+  pure $ view nse_getter_multi env
+
+
 
 listNgramsFromRepo :: [ListId]
                    -> NgramsType

src/Gargantext/Core/NodeStory/DB.hs

+{-|
+Module      : Gargantext.Core.NodeStory.DB
+Description : NodeStory DB functions
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+module Gargantext.Core.NodeStory.DB
+  ( nodeExists
+  , getNodesIdWithType
+  , getNodesArchiveHistory
+  , insertNodeArchiveHistory
+  , nodeStoriesQuery
+  , insertArchiveStateList
+  , deleteArchiveStateList
+  , updateArchiveStateList
+  , updateNodeStoryVersion )
+where
+
+import Control.Lens ((^.))
+import Control.Monad.Except
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HashMap
+import Data.Map.Strict qualified as Map
+import Data.Map.Strict.Patch qualified as PM
+import Data.Monoid
+import Database.PostgreSQL.Simple qualified as PGS
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
+import Gargantext.API.Ngrams.Types
+import Gargantext.Core (toDBid)
+import Gargantext.Core.NodeStory.Types
+import Gargantext.Core.Types (NodeId(..), NodeType)
+import Gargantext.Database.Admin.Config ()
+import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
+import Gargantext.Database.Schema.Ngrams (NgramsType)
+import Gargantext.Prelude hiding (to)
+import Gargantext.Prelude.Database
+
+
+nodeExists :: PGS.Connection -> NodeId -> IO Bool
+nodeExists c nId = (== [PGS.Only True])
+  <$> runPGSQuery c [sql| SELECT true FROM nodes WHERE id = ? LIMIT 1 |]
+                    (PGS.Only nId)
+
+getNodesIdWithType :: PGS.Connection -> NodeType -> IO [NodeId]
+getNodesIdWithType c nt = do
+  ns <- runPGSQuery c query (PGS.Only $ toDBid nt)
+  pure $ map (\(PGS.Only nId) -> UnsafeMkNodeId nId) ns
+  where
+    query :: PGS.Query
+    query = [sql| SELECT id FROM nodes WHERE typename = ? |]
+
+
+-- /!\ This function is using an hard coded parameter
+-- which depends on the Ngrams List Flow
+-- Version > 5 is hard coded because by default
+-- first version of history of manual change is 6
+getNodesArchiveHistory :: PGS.Connection
+                       -> [NodeId]
+                       -> IO [(NodeId, (Map NgramsType [HashMap NgramsTerm NgramsPatch]))]
+getNodesArchiveHistory c nodesId = do
+  as <- runPGSQuery c query (PGS.Only $ Values fields nodesId)
+                            :: IO [(Int, TableNgrams.NgramsType, NgramsTerm, NgramsPatch)]
+
+  pure $ map (\(nId, ngramsType, terms, patch)
+               -> ( UnsafeMkNodeId nId
+                  , Map.singleton ngramsType [HashMap.singleton terms patch]
+                  )
+             ) as
+  where
+
+    fields = [QualifiedIdentifier Nothing "int4"]
+    query :: PGS.Query
+    query = [sql| WITH nodes_id(nid) as (?)
+                    SELECT node_id, ngrams_type_id, terms, patch
+                    FROM node_story_archive_history
+                    JOIN ngrams ON ngrams.id = ngrams_id
+                    JOIN nodes_id n ON node_id = n.nid
+                    WHERE version > 5
+                    ORDER BY (version, node_story_archive_history.id) DESC
+            |]
+
+
+insertNodeArchiveHistory :: PGS.Connection -> NodeId -> Version -> [NgramsStatePatch'] -> IO ()
+insertNodeArchiveHistory _ _ _ [] = pure ()
+insertNodeArchiveHistory c nodeId version (h:hs) = do
+  let tuples = mconcat $ (\(nType, NgramsTablePatch patch) ->
+                           (\(term, p) ->
+                              (nodeId, nType, term, p)) <$> PM.toList patch) <$> PM.toList h :: [(NodeId, TableNgrams.NgramsType, NgramsTerm, NgramsPatch)]
+  tuplesM <- mapM (\(nId, nType, term, patch) -> do
+                      [PGS.Only ngramsId] <- runPGSReturning c qInsert [PGS.Only term] :: IO [PGS.Only Int]
+                      pure (nId, nType, ngramsId, term, patch)
+                  ) tuples :: IO [(NodeId, TableNgrams.NgramsType, Int, NgramsTerm, NgramsPatch)]
+  _ <- runPGSExecuteMany c query $ ((\(nId, nType, termId, _term, patch) -> (nId, nType, termId, patch, version)) <$> tuplesM)
+  _ <- insertNodeArchiveHistory c nodeId version hs
+  pure ()
+  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_story_archive_history(node_id, ngrams_type_id, ngrams_id, patch, version)
+                VALUES (?, ?, ?, ?, ?)
+                |]
+
+      
+nodeStoriesQuery :: PGS.Query
+nodeStoriesQuery = [sql| SELECT version, ngrams_type_id, terms, ngrams_repo_element
+                           FROM node_stories
+                           JOIN ngrams ON ngrams.id = ngrams_id
+                           WHERE node_id = ?
+                           |]
+
+
+-- Archive
+
+
+insertArchiveStateList :: PGS.Connection -> NodeId -> Version -> ArchiveStateList -> IO ()
+insertArchiveStateList c nodeId version as = do
+  mapM_ performInsert as
+  where
+    performInsert (ngramsType, ngrams, ngramsRepoElement) = do
+      [PGS.Only ngramsId] <- tryInsertTerms ngrams
+      _ <- case ngramsRepoElement ^. nre_root of
+        Nothing -> pure []
+        Just r -> tryInsertTerms r
+      mapM_ tryInsertTerms $ ngramsRepoElement ^. nre_children
+      runPGSExecute c query (nodeId, ngramsId, version, ngramsType, ngramsRepoElement)
+    
+    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|INSERT INTO node_stories(node_id, ngrams_id, version, ngrams_type_id, ngrams_repo_element)
+                VALUES (?, ?, ?, ?, ? :: jsonb)
+                |]
+
+deleteArchiveStateList :: PGS.Connection -> NodeId -> ArchiveStateList -> IO ()
+deleteArchiveStateList c nodeId as = do
+  mapM_ (\(nt, n, _) -> runPGSExecute c query (nodeId, nt, n)) as
+  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 = ?)
+                  |]
+
+updateArchiveStateList :: PGS.Connection -> NodeId -> Version -> ArchiveStateList -> IO ()
+updateArchiveStateList c nodeId version as = do
+  let params = (\(nt, n, nre) -> (nre, version, nodeId, nt, n)) <$> as
+  mapM_ (runPGSExecute c query) params
+  where
+    query :: PGS.Query
+    query = [sql| UPDATE node_stories
+                SET ngrams_repo_element = ?, version = ?
+                WHERE node_id = ? AND ngrams_type_id = ?
+                  AND ngrams_id IN (SELECT id FROM ngrams WHERE terms = ?)
+                  |]
+
+
+updateNodeStoryVersion :: PGS.Connection -> NodeId -> ArchiveList -> IO ()
+updateNodeStoryVersion c nodeId newArchive = do
+  let ngramsTypes = Map.keys $ newArchive ^. a_state
+  mapM_ (\nt -> runPGSExecute c query (newArchive ^. a_version, nodeId, nt)) ngramsTypes
+  where
+    query :: PGS.Query
+    query = [sql|UPDATE node_stories
+                SET version = ?
+                WHERE node_id = ?
+                AND ngrams_type_id = ?|]

src/Gargantext/Core/NodeStory/Types.hs

+{-|
+Module      : Gargantext.Core.NodeStory.Types
+Description : Node API generation
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+module Gargantext.Core.NodeStory.Types
+  ( HasNodeStory
+  , HasNodeStoryEnv
+  , hasNodeStory
+  , HasNodeStoryImmediateSaver
+  , hasNodeStoryImmediateSaver
+  , HasNodeArchiveStoryImmediateSaver
+  , hasNodeArchiveStoryImmediateSaver
+  , NodeStory(..)
+  , NgramsState'
+  , NgramsStatePatch'
+  , NodeListStory
+  , ArchiveList
+  , initNodeListStoryMock
+  , NodeStoryEnv(..)
+  , initNodeStory
+  , nse_getter
+  , nse_getter_multi
+  , nse_saver_immediate
+  , nse_archive_saver_immediate
+  -- , nse_var
+  , unNodeStory
+  , Archive(..)
+  , initArchive
+  , archiveAdvance
+  , unionArchives
+  , a_history
+  , a_state
+  , a_version
+  , combineState
+  , ArchiveStateSet
+  , ArchiveStateList )
+where
+
+import Codec.Serialise.Class
+import Control.Lens (makeLenses, Getter, (^.))
+import Control.Monad.Except
+import Control.Monad.Reader
+import Data.Aeson hiding ((.=), decode)
+import Data.Map.Strict qualified as Map
+import Data.Monoid
+import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+import Data.Semigroup
+import Data.Set qualified as Set
+import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
+import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Types (NodeId(..))
+import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Database.Admin.Config ()
+import Gargantext.Database.Prelude (DbCmd')
+import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
+import Gargantext.Prelude hiding (to)
+import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
+
+
+------------------------------------------------------------------------
+
+{- | Node Story for each NodeType where the Key of the Map is NodeId
+  TODO : generalize for any NodeType, let's start with NodeList which
+  is implemented already
+-}
+newtype NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
+  deriving (Generic, Show, Eq)
+
+instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
+instance (ToJSON s, ToJSON p) => ToJSON (NodeStory s p)
+instance (Serialise s, Serialise p) => Serialise (NodeStory s p)
+
+data Archive s p = Archive
+  { _a_version           :: !Version
+  , _a_state             :: !s
+  , _a_history           :: ![p]
+    -- first patch in the list is the most recent
+    -- We use `take` in `commitStatePatch`, that's why.
+
+    -- History is immutable, we just insert things on top of existing
+    -- list.
+
+    -- We don't need to store the whole history in memory, this
+    -- structure holds only recent history, the one that will be
+    -- inserted to the DB.
+  }
+  deriving (Generic, Show, Eq)
+
+instance (Serialise s, Serialise p) => Serialise (Archive s p)
+
+
+type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'
+
+-- NOTE: 'type NgramsTableMap = Map NgramsTerm NgramsRepoElement'
+type NgramsState'      = Map       TableNgrams.NgramsType NgramsTableMap
+type NgramsStatePatch' = PatchMap  TableNgrams.NgramsType NgramsTablePatch
+-- instance Serialise NgramsStatePatch'
+instance FromField (Archive NgramsState' NgramsStatePatch')
+  where
+    fromField = fromJSONField
+instance DefaultFromField SqlJsonb (Archive NgramsState' NgramsStatePatch')
+  where
+    defaultFromField = fromPGSFromField
+
+
+-- | Combine `NgramsState'`. This is because the structure is (Map
+-- NgramsType (Map ...)) and the default `(<>)` operator is
+-- left-biased
+-- (https://hackage.haskell.org/package/containers-0.6.6/docs/Data-Map-Internal.html#v:union)
+combineState :: NgramsState' -> NgramsState' -> NgramsState'
+combineState = Map.unionWith (<>)
+