Merge remote-tracking branch 'origin/131-dev-ngrams-table-db-connection-2' into dev-merge

bin/gargantext-client/Auth.hs

 module Auth where
 
 import Prelude
-import Data.Maybe
 import Core
 import Options
 

devops/postgres/upgrade/0.0.5.9.1.sql

+create table public.node_story_archive_history (
+  id SERIAL,
+  node_id INTEGER NOT NULL,
+  ngrams_type_id INTEGER NOT NULL,
+  ngrams_id INTEGER NOT NULL,
+  patch jsonb DEFAULT '{}'::jsonb NOT NULL,
+  PRIMARY KEY (id),
+  FOREIGN KEY (node_id) REFERENCES public.nodes(id) ON DELETE CASCADE,
+  FOREIGN KEY (ngrams_id) REFERENCES public.ngrams(id) ON DELETE CASCADE
+);
+ALTER TABLE public.node_story_archive_history OWNER TO gargantua;
+
+
+-- INSERT INTO node_story_archive_history (node_id, ngrams_type_id, patch) SELECT t.node_id, t.ngrams_type_id, t.patch FROM
+-- (
+-- WITH q AS (SELECT node_id, history.*, row_number() over (ORDER BY node_id) AS sid
+-- FROM node_stories,
+-- jsonb_to_recordset(archive->'history') AS history("Authors" jsonb, "Institutes" jsonb, "NgramsTerms" jsonb, "Sources" jsonb))
+
+-- (SELECT node_id, sid, 1 AS ngrams_type_id, "Authors" AS patch FROM q WHERE "Authors" IS NOT NULL)
+-- UNION (SELECT node_id, sid, 2 AS ngrams_type_id, "Institutes" AS patch FROM q WHERE "Institutes" IS NOT NULL)
+-- UNION (SELECT node_id, sid, 4 AS ngrams_type_id, "NgramsTerms" AS patch FROM q WHERE "NgramsTerms" IS NOT NULL)
+-- UNION (SELECT node_id, sid, 3 AS ngrams_type_id, "Sources" AS patch FROM q WHERE "Sources" IS NOT NULL)
+-- ORDER BY node_id, ngrams_type_id, sid
+-- ) AS t;

devops/postgres/upgrade/0.0.5.9.sql

+create table public.node_stories (
+  id SERIAL,
+  node_id INTEGER NOT NULL,
+  archive jsonb DEFAULT '{}'::jsonb NOT NULL,
+  PRIMARY KEY (id),
+  FOREIGN KEY (node_id) REFERENCES public.nodes(id) ON DELETE CASCADE
+);
+ALTER TABLE public.node_stories OWNER TO gargantua;
+
+CREATE UNIQUE INDEX ON public.node_stories USING btree (node_id);

gargantext.cabal

@@ -162,6 +162,7 @@ library
       Gargantext.Core.Methods.Graph.BAC.Proxemy
       Gargantext.Core.Methods.Graph.MaxClique
       Gargantext.Core.Methods.Matrix.Accelerate.Utils
+      Gargantext.Core.NodeStoryFile
       Gargantext.Core.Statistics
       Gargantext.Core.Text.Convert
       Gargantext.Core.Text.Corpus.API.Arxiv
@@ -410,6 +411,7 @@ library
     , jose
     , json-stream
     , lens
+    , lifted-base
     , listsafe
     , located-base
     , logging-effect

package.yaml

@@ -195,6 +195,7 @@ library:
   - jose
   - json-stream
   - lens
+  - lifted-base
   - listsafe
   - located-base
   - logging-effect

src/Gargantext/API.hs

@@ -117,9 +117,9 @@ makeMockApp env = do
             blocking <- fireWall req (env ^. menv_firewall)
             case blocking  of
                 True  -> app req resp
-                False -> resp ( responseLBS status401 [] 
+                False -> resp ( responseLBS status401 []
                               "Invalid Origin or Host header")
-        
+
     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
             { corsOrigins        = Nothing --  == /*
@@ -135,7 +135,7 @@ makeMockApp env = do
 
     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
     --          $ Warp.defaultSettings
-    
+
     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 -}
@@ -149,7 +149,7 @@ makeDevMiddleware mode = do
 --            blocking <- fireWall req (env ^. menv_firewall)
 --            case blocking  of
 --                True  -> app req resp
---                False -> resp ( responseLBS status401 [] 
+--                False -> resp ( responseLBS status401 []
 --                              "Invalid Origin or Host header")
 --
     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy

src/Gargantext/API/Admin/Settings.hs

-{-| 
+{-|
 Module      : Gargantext.API.Admin.Settings
 Description : Settings of the API (Server and Client)
 Copyright   : (c) CNRS, 2017-Present
@@ -27,7 +27,7 @@ import Data.Maybe (fromMaybe)
 import Data.Pool (Pool, createPool)
 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
 import Gargantext.Core.NodeStory
-import Gargantext.Prelude.Config (GargConfig(..), {-gc_repofilepath,-} readConfig)
+import Gargantext.Prelude.Config ({-GargConfig(..),-} {-gc_repofilepath,-} readConfig)
 import Network.HTTP.Client.TLS (newTlsManager)
 import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
 import Servant.Client (parseBaseUrl)
@@ -180,7 +180,8 @@ newEnv 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 (_gc_repofilepath config_env)
+  nodeStory_env <- readNodeStoryEnv pool
   scrapers_env  <- newJobEnv defaultSettings manager_env
   logger        <- newStderrLoggerSet defaultBufSize
   config_mail   <- Mail.readConfig file

src/Gargantext/API/Dev.hs

 {-|
 Module      : Gargantext.API.Dev
-Description : 
+Description :
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3
 Maintainer  : team@gargantext.org
@@ -22,7 +22,7 @@ import Gargantext.API.Prelude
 import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude
 import Gargantext.Prelude
-import Gargantext.Prelude.Config (GargConfig(..), readConfig)
+import Gargantext.Prelude.Config (readConfig)
 import qualified Gargantext.Prelude.Mail as Mail
 import Servant
 import System.IO (FilePath)
@@ -38,8 +38,9 @@ withDevEnv iniPath k = do
     newDevEnv = do
       cfg     <- readConfig         iniPath
       dbParam <- databaseParameters iniPath
-      nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
+      --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
       pool    <- newPool            dbParam
+      nodeStory_env <- readNodeStoryEnv pool
       setts   <- devSettings devJwkFile
       mail    <- Mail.readConfig iniPath
       pure $ DevEnv
@@ -61,7 +62,7 @@ runCmdReplServantErr = runCmdRepl
 -- the command.
 -- This function is constrained to the DevEnv rather than
 -- using HasConnectionPool and HasRepoVar.
-runCmdDev :: (Show err) => DevEnv -> Cmd'' DevEnv err a -> IO a
+runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
 runCmdDev env f =
   (either (fail . show) pure =<< runCmd env f)
     `finally`

src/Gargantext/API/Ngrams.hs

@@ -11,7 +11,7 @@ Ngrams API
 
 -- | TODO
 get ngrams filtered by NgramsType
-add get 
+add get
 
 -}
 
@@ -106,7 +106,7 @@ import Gargantext.Database.Action.Flow.Types
 import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast')
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Types.Node (NodeType(..))
-import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig)
 import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngramsType, ngrams_terms)
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
@@ -261,7 +261,9 @@ setListNgrams listId ngramsType ns = do
 currentVersion :: HasNodeStory env err m
                => ListId -> m Version
 currentVersion listId = do
-  nls <- getRepo [listId]
+  --nls <- getRepo [listId]
+  pool <- view connPool
+  nls <- liftBase $ getNodeStory pool listId
   pure $ nls ^. unNodeStory . at listId . _Just . a_version
 
 
@@ -282,13 +284,16 @@ commitStatePatch :: (HasNodeStory env err m, HasMail env)
                  => ListId
                  ->    Versioned NgramsStatePatch'
                  -> m (Versioned NgramsStatePatch')
-commitStatePatch listId (Versioned p_version p) = do
+commitStatePatch listId (Versioned _p_version p) = do
   -- printDebug "[commitStatePatch]" listId
   var <- getNodeStoryVar [listId]
   vq' <- liftBase $ modifyMVar var $ \ns -> do
     let
       a = ns ^. unNodeStory . at listId . _Just
-      q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
+      -- 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
       (p', q') = transformWith ngramsStatePatchConflictResolution p q
       a' = a & a_version +~ 1
              & a_state   %~ act p'
@@ -808,5 +813,3 @@ listNgramsChangedSince listId ngramsType version
       Versioned <$> currentVersion listId <*> pure True
   | otherwise   =
       tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
-
-

src/Gargantext/API/Ngrams/Tools.hs

@@ -22,13 +22,16 @@ import Data.Hashable (Hashable)
 import Data.Set (Set)
 import Data.Validity
 import Gargantext.API.Ngrams.Types
-import Gargantext.Core.Types (ListType(..), NodeId, ListId)
+import Gargantext.Core.Types (ListType(..), NodeId, NodeType(..), ListId)
+import Gargantext.Database.Prelude (CmdM, HasConnectionPool(..))
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map.Strict     as Map
 import qualified Data.Set            as Set
 import Gargantext.Core.NodeStory
+import qualified Gargantext.Core.NodeStoryFile as NSF
+
 
 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
 mergeNgramsElement _neOld neNew = neNew
@@ -193,3 +196,21 @@ getCoocByNgrams' f (Diagonal diag) m =
   where ks = HM.keys m
 
 ------------------------------------------
+
+
+migrateFromDirToDb :: (CmdM env err m, HasNodeStory env err m)
+                   => m ()
+migrateFromDirToDb = do
+  pool <- view connPool
+  listIds <- liftBase $ getNodesIdWithType pool NodeList
+  printDebug "[migrateFromDirToDb] listIds" listIds
+  (NodeStory nls) <- NSF.getRepoReadConfig listIds
+  printDebug "[migrateFromDirToDb] nls" nls
+  _ <- mapM (\(nId, a) -> do
+                n <- liftBase $ nodeExists pool nId
+                case n of
+                  False -> pure 0
+                  True  -> liftBase $ upsertNodeArchive pool nId a
+            ) $ Map.toList nls
+  --_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
+  pure ()

src/Gargantext/API/Ngrams/Types.hs

@@ -28,7 +28,8 @@ import Data.String (IsString, fromString)
 import Data.Swagger hiding (version, patch)
 import Data.Text (Text, pack, strip)
 import Data.Validity
-import Database.PostgreSQL.Simple.FromField (FromField, fromField, ResultError(ConversionFailed), returnError)
+import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField, ResultError(ConversionFailed), returnError)
+import Database.PostgreSQL.Simple.ToField (ToField, toJSONField, toField)
 import GHC.Generics (Generic)
 import Gargantext.Core.Text (size)
 import Gargantext.Core.Types (ListType(..), ListId, NodeId, TODO)
@@ -124,19 +125,14 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
 ------------------------------------------------------------------------
 newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text }
   deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable, NFData)
-
 instance IsHashable NgramsTerm where
   hash (NgramsTerm t) = hash t
-
 instance Monoid NgramsTerm where
   mempty = NgramsTerm ""
-
 instance FromJSONKey NgramsTerm where
   fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t
-
 instance IsString NgramsTerm where
   fromString s = NgramsTerm $ pack s
-
 instance FromField NgramsTerm
   where
     fromField field mb = do
@@ -147,6 +143,9 @@ instance FromField NgramsTerm
                       $ List.intercalate " " [ "cannot parse hyperdata for JSON: "
                                              , show v
                                              ]
+instance ToField NgramsTerm where
+  toField (NgramsTerm n) = toField n
+
 
 data RootParent = RootParent
   { _rp_root   :: NgramsTerm
@@ -448,13 +447,16 @@ instance ToSchema NgramsPatch where
                 , ("old",      nreSch)
                 , ("new",      nreSch)
                 ]
-
 instance Arbitrary NgramsPatch where
   arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
                         , (1, NgramsReplace <$> arbitrary <*> arbitrary)
                         ]
-
 instance Serialise NgramsPatch
+instance FromField NgramsPatch where
+  fromField = fromJSONField
+instance ToField NgramsPatch where
+  toField = toJSONField
+
 instance Serialise (Replace ListType)
 
 instance Serialise ListType
@@ -512,7 +514,6 @@ instance Action (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepo
 
 instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
   applicable p = applicable (p ^. _NgramsPatch)
-
 instance Action NgramsPatch (Maybe NgramsRepoElement) where
   act p = act (p ^. _NgramsPatch)
 
@@ -524,7 +525,11 @@ instance Serialise (PatchMap NgramsTerm NgramsPatch)
 
 instance FromField NgramsTablePatch
   where
-    fromField = fromField'
+    fromField = fromJSONField
+    --fromField = fromField'
+instance ToField NgramsTablePatch
+  where
+    toField = toJSONField
 
 instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
   where
@@ -751,4 +756,3 @@ instance ToSchema UpdateTableNgramsCharts where
 
 ------------------------------------------------------------------------
 type NgramsList = (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
-

src/Gargantext/Core/NodeStory.hs

@@ -10,6 +10,30 @@ Portability : POSIX
 A Node Story is a Map between NodeId and an Archive (with state,
 version and history) for that node.
 
+Couple of words on how this is implemented.
+
+First version used files which stored Archive for each NodeId in a
+separate .cbor file.
+
+For performance reasons, it is rewritten to use the DB.
+
+The table `node_stories` contains two columns: `node_id` and
+`archive`.
+
+Next, it was observed that `a_history` in `Archive` takes much
+space. So a new table was created, `node_story_archive_history` with
+columns: `node_id`, `ngrams_type_id`, `patch`. This is because each
+history item is in fact a map from `NgramsType` to `NgramsTablePatch`
+(see the `NgramsStatePatch'` type).
+
+Moreover, since in ~G.A.Ngrams.commitStatePatch~ we use current state
+only, with only recent history items, I concluded that it is not
+necessary to load whole history into memory. Instead, it is kept in DB
+(history is immutable) and only recent changes are added to
+`a_history`. Then that record is cleared whenever `Archive` is saved.
+
+Please note that
+
 TODO:
 - remove
 - filter
@@ -17,36 +41,75 @@ TODO:
 -}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE Arrows #-}
 {-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
-module Gargantext.Core.NodeStory where
+module Gargantext.Core.NodeStory
+  ( HasNodeStory
+  , HasNodeStoryEnv
+  , hasNodeStory
+  , HasNodeStoryVar
+  , hasNodeStoryVar
+  , HasNodeStorySaver
+  , hasNodeStorySaver
+  , NodeStory(..)
+  , NgramsStatePatch'
+  , NodeListStory
+  , initNodeListStoryMock
+  , NodeStoryEnv(..)
+  , initNodeStory
+  , nse_getter
+  , nse_saver
+  , nse_var
+  , unNodeStory
+  , getNodeArchiveHistory
+  , Archive(..)
+  , initArchive
+  , a_history
+  , a_state
+  , a_version
+  , nodeExists
+  , getNodesIdWithType
+  , readNodeStoryEnv
+  , upsertNodeArchive
+  , getNodeStory )
+where
 
 -- import Debug.Trace (traceShow)
-import Codec.Serialise (serialise, deserialise)
-import Codec.Serialise.Class 
-import Control.Concurrent (MVar(), withMVar, newMVar, modifyMVar_)
 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
-import Control.Lens (makeLenses, Getter, (^.))
+import Codec.Serialise.Class
+import Control.Arrow (returnA)
+import Control.Concurrent (MVar(), withMVar, newMVar, modifyMVar_)
+import Control.Exception (catch, throw, SomeException(..))
+import Control.Lens (makeLenses, Getter, (^.), (.~), traverse)
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Aeson hiding ((.=), decode)
+import Data.ByteString.Char8 (hPutStrLn)
 import Data.Map.Strict (Map)
+import Data.Maybe (catMaybes, mapMaybe)
 import Data.Monoid
+import Data.Pool (Pool, withResource)
 import Data.Semigroup
+import qualified Database.PostgreSQL.Simple as PGS
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
+import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import GHC.Generics (Generic)
 import Gargantext.API.Ngrams.Types
-import Gargantext.Core.Types (NodeId)
+import Gargantext.Core.Types (NodeId(..), NodeType)
 import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Database.Admin.Config (nodeTypeId)
 import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
 import Gargantext.Prelude
-import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
-import System.IO (FilePath, hClose)
-import System.IO.Temp (withTempFile)
-import qualified Data.ByteString.Lazy                   as DBL
-import qualified Data.List                              as List
+import Opaleye (Column, DefaultFromField(..), Insert(..), Select, SqlInt4, SqlJsonb, Table, Update(..), (.==), fromPGSFromField, rCount, restrict, runInsert, runSelect, runUpdate, selectTable, sqlInt4, sqlValueJSONB, tableField, updateEasy)
+import Opaleye.Internal.Table (Table(..))
+import System.IO (stderr)
 import qualified Data.Map.Strict                        as Map
+import qualified Data.Map.Strict.Patch                  as PM
 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 
 ------------------------------------------------------------------------
@@ -79,183 +142,12 @@ class HasNodeStorySaver env where
   hasNodeStorySaver :: Getter env (IO ())
 
 ------------------------------------------------------------------------
-readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
-readNodeStoryEnv nsd = do
-  mvar  <- nodeStoryVar nsd Nothing [0]
-  saver <- mkNodeStorySaver nsd mvar
-  pure $ NodeStoryEnv { _nse_var = mvar
-                      , _nse_saver = saver
-                      , _nse_getter = nodeStoryVar nsd (Just mvar) }
-
-------------------------------------------------------------------------
-mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
-mkNodeStorySaver nsd mvns = mkDebounce settings
-  where
-    settings = defaultDebounceSettings
-                 { debounceAction = withMVar mvns (writeNodeStories nsd)
-                 , debounceFreq = 1 * minute
---                 , debounceEdge = trailingEdge -- Trigger on the trailing edge
-                 }
-    minute = 60 * second
-    second = 10^(6 :: Int)
-
-nodeStoryVar :: NodeStoryDir
-             -> Maybe (MVar NodeListStory)
-             -> [NodeId]
-             -> IO (MVar NodeListStory)
-nodeStoryVar nsd Nothing ni = nodeStoryIncs nsd Nothing ni >>= newMVar
-nodeStoryVar nsd (Just mv) ni = do
-  _ <- modifyMVar_ mv $ \mv' -> (nodeStoryIncs nsd (Just mv') ni)
-  pure mv
-
-
-nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
-nodeStoryInc nsd (Just ns@(NodeStory nls)) ni = do
-  case Map.lookup ni nls of
-    Nothing -> do
-      (NodeStory nls') <- nodeStoryRead nsd ni
-      pure $ NodeStory $ Map.union nls nls'
-    Just _  -> pure ns
-nodeStoryInc nsd Nothing ni = nodeStoryRead nsd ni
-
-
-nodeStoryIncs :: NodeStoryDir
-              -> Maybe NodeListStory
-              -> [NodeId]
-              -> IO NodeListStory
-nodeStoryIncs _ Nothing    []        = panic "nodeStoryIncs: Empty"
-nodeStoryIncs nsd (Just nls) ns      = foldM (\m n -> nodeStoryInc nsd (Just m) n) nls ns
-nodeStoryIncs nsd Nothing    (ni:ns) = do
-  m <- nodeStoryRead nsd ni
-  nodeStoryIncs nsd (Just m) ns
-
-
-nodeStoryDec :: NodeStoryDir
-             -> NodeListStory
-             -> NodeId
-             -> IO NodeListStory
-nodeStoryDec nsd ns@(NodeStory nls) ni = do
-  case Map.lookup ni nls of
-    Nothing -> do
-      -- we make sure the corresponding file repo is really removed
-      _ <- nodeStoryRemove nsd ni
-      pure ns
-    Just _  -> do
-      let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
-      _ <- nodeStoryRemove nsd ni
-      pure $ NodeStory ns'
-
--- | TODO lock
-nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
-nodeStoryRead nsd ni = do
-  _repoDir <- createDirectoryIfMissing True nsd
-  let nsp = nodeStoryPath nsd ni
-  exists <- doesFileExist nsp
-  if exists
-     then deserialise <$> DBL.readFile nsp
-     else pure (initNodeStory ni)
-
-nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
-nodeStoryRemove nsd ni = do
-  let nsp = nodeStoryPath nsd ni
-  exists <- doesFileExist nsp
-  if exists
-     then removeFile nsp
-     else pure ()
-
-
-
-nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
-nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
-                          $ fmap Map.keys
-                          $ fmap _a_state
-                          $ Map.lookup ni
-                          $ _unNodeStory n
-
-------------------------------------------------------------------------
-type NodeStoryDir = FilePath
-
-writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
-writeNodeStories fp nls = do
-  _done <- mapM (writeNodeStory fp) $ splitByNode nls
-  -- printDebug "[writeNodeStories]" done
-  pure ()
-
-writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
-writeNodeStory rdfp (n, ns) = saverAction' rdfp n ns
-
-splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
-splitByNode (NodeStory m) =
-  List.map (\(n,a) -> (n, NodeStory $ Map.singleton n a)) $ Map.toList m
-
-
-saverAction' :: Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
-saverAction' repoDir nId a = do
-  withTempFile repoDir ((cs $ show nId) <> "-tmp-repo.cbor") $ \fp h -> do
-    -- printDebug "[repoSaverAction]" fp
-    DBL.hPut h $ serialise a
-    hClose h
-    renameFile fp (nodeStoryPath repoDir nId)
-
-nodeStoryPath :: NodeStoryDir -> NodeId -> FilePath
-nodeStoryPath repoDir nId = repoDir <> "/" <> filename
-  where
-    filename = "repo" <> "-" <> (cs $ show nId) <> ".cbor"
-
-
-------------------------------------------------------------------------
--- TODO : repo Migration TODO TESTS
-{-
-repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
-repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
-
-repoToNodeListStory :: NgramsRepo -> NodeListStory
-repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
-  where
-    s' = ngramsState_migration      s
-    h' = ngramsStatePatch_migration h
-    ns = List.map (\(n,ns')
-                    -> (n, let hs = fromMaybe [] (Map.lookup n h') in
-                               Archive { _a_version = List.length hs
-                                       , _a_state = ns'
-                                       , _a_history = hs }
-                       )
-                  ) $ Map.toList s'
-
-ngramsState_migration :: NgramsState
-                      -> Map NodeId NgramsState'
-ngramsState_migration ns =
-  Map.fromListWith (Map.union) $ 
-  List.concat $
-    map (\(nt, nTable)
-          -> map (\(nid, table)
-                   -> (nid, Map.singleton nt table)
-                 ) $ Map.toList nTable
-        ) $ Map.toList ns
-
-
-ngramsStatePatch_migration :: [NgramsStatePatch]
-                           -> Map NodeId [NgramsStatePatch']
-ngramsStatePatch_migration np' = Map.fromListWith (<>)
-                               $ List.concat
-                               $ map toPatch np'
-  where
-    toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
-    toPatch p = 
-      List.concat $
-        map (\(nt, nTable)
-              -> map (\(nid, table)
-                       -> (nid, [fst $ Patch.singleton nt table])
-                     ) $ Patch.toList nTable
-            ) $ Patch.toList p
--}
-------------------------------------------------------------------------
 
 {- | 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
 -}
-data NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
+newtype NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
   deriving (Generic, Show)
 
 instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
@@ -263,10 +155,18 @@ 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]
+  { _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)
 
@@ -278,18 +178,24 @@ type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'
 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
 
 -- TODO Semigroup instance for unions
 -- TODO check this
 instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
   (<>) (Archive { _a_history = p }) (Archive { _a_version = v'
                                              , _a_state = s'
-                                             , _a_history = p'}) =
+                                             , _a_history = p' }) =
     Archive { _a_version = v'
             , _a_state = s'
             , _a_history = p' <> p }
 
-instance Monoid (Archive NgramsState' NgramsStatePatch') where
+instance (Monoid s, Semigroup p) => Monoid (Archive s p) where
   mempty = Archive { _a_version = 0
                    , _a_state = mempty
                    , _a_history = [] }
@@ -302,13 +208,11 @@ instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
   toEncoding = genericToEncoding $ unPrefix "_a_"
 
 ------------------------------------------------------------------------
-initNodeStory :: Monoid s => NodeId -> NodeStory s p
+initNodeStory :: (Monoid s, Semigroup p) => NodeId -> NodeStory s p
 initNodeStory ni = NodeStory $ Map.singleton ni initArchive
 
-initArchive :: Monoid s => Archive s p
-initArchive = Archive { _a_version = 0
-                      , _a_state = mempty
-                      , _a_history = [] }
+initArchive :: (Monoid s, Semigroup p) => Archive s p
+initArchive = mempty
 
 initNodeListStoryMock :: NodeListStory
 initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
@@ -331,3 +235,243 @@ initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
 makeLenses ''NodeStoryEnv
 makeLenses ''NodeStory
 makeLenses ''Archive
+
+-----------------------------------------
+
+
+data NodeStoryPoly a b = NodeStoryDB { node_id :: a
+                                     , archive :: b }
+  deriving (Eq)
+
+type ArchiveQ = Archive NgramsState' NgramsStatePatch'
+
+type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
+type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
+
+$(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
+
+
+runPGSExecuteMany :: (PGS.ToRow q) => Pool PGS.Connection -> PGS.Query -> [q] -> IO Int64
+runPGSExecuteMany pool qs a = withResource pool $ \c -> catch (PGS.executeMany c qs a) (printError c)
+  where
+    printError _c (SomeException e) = do
+      --q' <- PGS.formatQuery c qs a
+      --hPutStrLn stderr q'
+      throw (SomeException e)
+
+runPGSQuery :: (PGS.FromRow r, PGS.ToRow q) => Pool PGS.Connection -> PGS.Query -> q -> IO [r]
+runPGSQuery pool q a = withResource pool $ \c -> catch (PGS.query c q a) (printError c)
+  where
+    printError c (SomeException e) = do
+      q' <- PGS.formatQuery c q a
+      hPutStrLn stderr q'
+      throw (SomeException e)
+
+nodeExists :: Pool PGS.Connection -> NodeId -> IO Bool
+nodeExists pool nId = (== [PGS.Only True])
+  <$> runPGSQuery pool [sql|SELECT true FROM nodes WHERE id = ? AND ? |] (nId, True)
+
+getNodesIdWithType :: Pool PGS.Connection -> NodeType -> IO [NodeId]
+getNodesIdWithType pool nt = do
+  ns <- runPGSQuery pool query (nodeTypeId nt, True)
+  pure $ map (\(PGS.Only nId) -> NodeId nId) ns
+  where
+    query :: PGS.Query
+    query = [sql|SELECT id FROM nodes WHERE typename = ? AND ? |]
+
+
+
+nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
+nodeStoryTable =
+  Table "node_stories"
+    ( pNodeStory NodeStoryDB { node_id = tableField "node_id"
+                             , archive = tableField "archive" } )
+
+nodeStorySelect :: Select NodeStoryRead
+nodeStorySelect = selectTable nodeStoryTable
+
+-- TODO Check ordering, "first patch in the _a_history list is the most recent"
+getNodeArchiveHistory :: Pool PGS.Connection -> NodeId -> IO [NgramsStatePatch']
+getNodeArchiveHistory pool nodeId = do
+  as <- runPGSQuery pool query (nodeId, True)
+  let asTuples = mapMaybe (\(ngrams_type_id, ngrams, patch) -> (\ntId -> (ntId, ngrams, patch)) <$> (TableNgrams.fromNgramsTypeId ngrams_type_id)) as
+  pure $ (\(ntId, terms, patch) -> fst $ PM.singleton ntId (NgramsTablePatch $ fst $ PM.singleton terms patch)) <$> asTuples
+  where
+    query :: PGS.Query
+    query = [sql|SELECT ngrams_type_id, terms, patch
+                   FROM node_story_archive_history
+                   JOIN ngrams ON ngrams.id = ngrams_id
+                   WHERE node_id = ? AND ? |]
+
+insertNodeArchiveHistory :: Pool PGS.Connection -> NodeId -> [NgramsStatePatch'] -> IO ()
+insertNodeArchiveHistory _ _ [] = pure ()
+insertNodeArchiveHistory pool nodeId (h:hs) = do
+  let tuples = mconcat $ (\(nType, (NgramsTablePatch patch)) ->
+                           (\(term, p) ->
+                              (nodeId, TableNgrams.ngramsTypeId nType, term, p)) <$> PM.toList patch) <$> PM.toList h :: [(NodeId, TableNgrams.NgramsTypeId, NgramsTerm, NgramsPatch)]
+  tuplesM <- mapM (\(nId, nTypeId, term, patch) -> do
+                      ngrams <- runPGSQuery pool ngramsQuery (term, True)
+                      pure $ (\(PGS.Only termId) -> (nId, nTypeId, termId, term, patch)) <$> (headMay ngrams)
+                      ) tuples :: IO [Maybe (NodeId, TableNgrams.NgramsTypeId, Int, NgramsTerm, NgramsPatch)]
+  _ <- runPGSExecuteMany pool query $ ((\(nId, nTypeId, termId, _term, patch) -> (nId, nTypeId, termId, patch)) <$> (catMaybes tuplesM))
+  _ <- insertNodeArchiveHistory pool nodeId hs
+  pure ()
+  where
+    ngramsQuery :: PGS.Query
+    ngramsQuery = [sql| SELECT id FROM ngrams WHERE terms = ? AND ? |]
+
+    query :: PGS.Query
+    query = [sql| INSERT INTO node_story_archive_history(node_id, ngrams_type_id, ngrams_id, patch) VALUES (?, ?, ?, ?) |]
+
+getNodeStory :: Pool PGS.Connection -> NodeId -> IO NodeListStory
+getNodeStory pool (NodeId nodeId) = do
+  res <- withResource pool $ \c -> runSelect c query :: IO [NodeStoryPoly NodeId ArchiveQ]
+  withArchive <- mapM (\(NodeStoryDB { node_id = nId, archive = Archive { .. } }) -> do
+           --a <- getNodeArchiveHistory pool nId
+           let a = [] :: [NgramsStatePatch']
+           -- Don't read whole history. Only state is needed and most recent changes.
+           pure (nId, Archive { _a_history = a, .. })) res
+  pure $ NodeStory $ Map.fromListWith (<>) withArchive
+  --pure $ NodeStory $ Map.fromListWith (<>) $ (\(NodeStoryDB nId a) -> (nId, a)) <$> res
+  where
+    query :: Select NodeStoryRead
+    query = proc () -> do
+      row@(NodeStoryDB node_id _) <- nodeStorySelect -< ()
+      restrict -< node_id .== sqlInt4 nodeId
+      returnA -< row
+
+insertNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
+insertNodeArchive pool nodeId@(NodeId nId) (Archive {..}) = do
+  ret <- withResource pool $ \c -> runInsert c insert
+  -- NOTE: It is assumed that the most recent change is the first in the
+  -- list, so we save these in reverse order
+  insertNodeArchiveHistory pool nodeId $ reverse _a_history
+  pure ret
+  where
+    emptyHistory = [] :: [NgramsStatePatch']
+    insert = Insert { iTable      = nodeStoryTable
+                    , iRows       = [NodeStoryDB { node_id = sqlInt4 nId
+                                                 , archive = sqlValueJSONB $ Archive { _a_history = emptyHistory
+                                                                                     , .. } }]
+                    , iReturning  = rCount
+                    , iOnConflict = Nothing }
+
+updateNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
+updateNodeArchive pool nodeId@(NodeId nId) (Archive {..}) = do
+  ret <- withResource pool $ \c -> runUpdate c update
+  -- NOTE: It is assumed that the most recent change is the first in the
+  -- list, so we save these in reverse order
+  insertNodeArchiveHistory pool nodeId $ reverse _a_history
+  pure ret
+  where
+    emptyHistory = [] :: [NgramsStatePatch']
+    update = Update { uTable      = nodeStoryTable
+                    , uUpdateWith = updateEasy (\(NodeStoryDB { node_id }) -> NodeStoryDB { archive = sqlValueJSONB $ Archive { _a_history = emptyHistory
+                                                                                                                              , ..}
+                                                                                     , .. })
+                    , uWhere      = (\row -> node_id row .== sqlInt4 nId)
+                    , uReturning  = rCount }
+
+-- nodeStoryRemove :: Pool PGS.Connection -> NodeId -> IO Int64
+-- nodeStoryRemove pool (NodeId nId) = withResource pool $ \c -> runDelete c delete
+--   where
+--     delete = Delete { dTable     = nodeStoryTable
+--                     , dWhere     = (\row -> node_id row .== sqlInt4 nId)
+--                     , dReturning = rCount }
+
+upsertNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
+upsertNodeArchive pool nId a = do
+  (NodeStory m) <- getNodeStory pool nId
+  case Map.lookup nId m of
+    Nothing -> insertNodeArchive pool nId a
+    Just _  -> updateNodeArchive pool nId a
+
+writeNodeStories :: Pool PGS.Connection -> NodeListStory -> IO ()
+writeNodeStories pool (NodeStory nls) = do
+  _ <- mapM (\(nId, a) -> upsertNodeArchive pool nId a) $ Map.toList nls
+  pure ()
+
+-- | Returns a `NodeListStory`, updating the given one for given `NodeId`
+nodeStoryInc :: Pool PGS.Connection -> Maybe NodeListStory -> NodeId -> IO NodeListStory
+nodeStoryInc pool Nothing nId = getNodeStory pool nId
+nodeStoryInc pool (Just ns@(NodeStory nls)) nId = do
+  case Map.lookup nId nls of
+    Nothing -> do
+      (NodeStory nls') <- getNodeStory pool nId
+      pure $ NodeStory $ Map.union nls nls'
+    Just _ -> pure ns
+
+nodeStoryIncs :: Pool PGS.Connection -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
+nodeStoryIncs _ Nothing [] = pure $ NodeStory $ Map.empty
+nodeStoryIncs pool (Just nls) ns = foldM (\m n -> nodeStoryInc pool (Just m) n) nls ns
+nodeStoryIncs pool Nothing (ni:ns) = do
+  m <- getNodeStory pool ni
+  nodeStoryIncs pool (Just m) ns
+
+-- nodeStoryDec :: Pool PGS.Connection -> NodeListStory -> NodeId -> IO NodeListStory
+-- nodeStoryDec pool ns@(NodeStory nls) ni = do
+--   case Map.lookup ni nls of
+--     Nothing -> do
+--       _ <- nodeStoryRemove pool ni
+--       pure ns
+--     Just _ -> do
+--       let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
+--       _ <- nodeStoryRemove pool ni
+--       pure $ NodeStory ns'
+------------------------------------
+
+readNodeStoryEnv :: Pool PGS.Connection -> IO NodeStoryEnv
+readNodeStoryEnv pool = do
+  mvar <- nodeStoryVar pool Nothing []
+  saver <- mkNodeStorySaver pool mvar
+  -- let saver = modifyMVar_ mvar $ \mv -> do
+  --       writeNodeStories pool mv
+  --       printDebug "[readNodeStoryEnv] saver" mv
+  --       let mv' = clearHistory mv
+  --       printDebug "[readNodeStoryEnv] saver, cleared" mv'
+  --       return mv'
+  pure $ NodeStoryEnv { _nse_var    = mvar
+                      , _nse_saver  = saver
+                      , _nse_getter = nodeStoryVar pool (Just mvar) }
+
+nodeStoryVar :: Pool PGS.Connection -> Maybe (MVar NodeListStory) -> [NodeId] -> IO (MVar NodeListStory)
+nodeStoryVar pool Nothing nIds = do
+  state <- nodeStoryIncs pool Nothing nIds
+  newMVar state
+nodeStoryVar pool (Just mv) nIds = do
+  _ <- modifyMVar_ mv $ \nsl -> (nodeStoryIncs pool (Just nsl) nIds)
+  pure mv
+
+-- 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 = mkDebounce settings
+  where
+    settings = defaultDebounceSettings
+                 { debounceAction = do
+                     withMVar mvns (\ns -> writeNodeStories pool ns)
+                     withMVar mvns (\ns -> printDebug "[mkNodeStorySaver] debounce nodestory" ns)
+                     modifyMVar_ mvns $ \ns -> pure $ clearHistory ns
+                 , debounceFreq = 1*minute
+                 }
+    minute = 60*second
+    second = 10^(6 :: Int)
+
+clearHistory :: NodeListStory -> NodeListStory
+clearHistory (NodeStory ns) = NodeStory $ ns & (traverse . a_history) .~ emptyHistory
+  where
+    emptyHistory = [] :: [NgramsStatePatch']
+
+-- mkNodeStorySaver :: MVar NodeListStory -> Cmd err (Cmd err ())
+-- mkNodeStorySaver mvns = mkDebounce settings
+--   where
+--     settings = defaultDebounceSettings
+--                  { debounceAction = withMVar mvns (\ns -> writeNodeStories ns)
+--                  , debounceFreq = 1 * minute
+-- --                 , debounceEdge = trailingEdge -- Trigger on the trailing edge
+--                  }
+--     minute = 60 * second
+--     second = 10^(6 :: Int)
+
+
+-----------------------------------------

src/Gargantext/Core/NodeStoryFile.hs

+{- NOTE This is legacy code. It keeps node stories in a directory
+ repo. We now have migrated to the DB. However this code is needed to
+ make the migration (see  Gargantext.API.Ngrams.Tools) -}
+
+module Gargantext.Core.NodeStoryFile where
+
+import Control.Lens (view)
+import Control.Monad (foldM)
+import Codec.Serialise (serialise, deserialise)
+import Codec.Serialise.Class
+import Control.Concurrent (MVar(), modifyMVar_, newMVar, readMVar, withMVar)
+import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
+import Gargantext.Core.NodeStory hiding (readNodeStoryEnv)
+import Gargantext.Core.Types (ListId, NodeId(..))
+import Gargantext.Database.Prelude (CmdM, hasConfig)
+import Gargantext.Prelude
+import Gargantext.Prelude.Config (gc_repofilepath)
+import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
+import System.IO (FilePath, hClose)
+import System.IO.Temp (withTempFile)
+import qualified Data.ByteString.Lazy                   as DBL
+import qualified Data.List                              as List
+import qualified Data.Map.Strict                        as Map
+import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
+
+
+getRepo :: HasNodeStory env err m
+         => [ListId] -> m NodeListStory
+getRepo listIds = do
+  g <- getNodeListStory
+  liftBase $ do
+    v <- g listIds
+    readMVar v
+  -- v  <- liftBase $ f listIds
+  -- v' <- liftBase $ readMVar v
+  -- pure $ v'
+
+getRepoReadConfig :: (CmdM env err m)
+             => [ListId] -> m NodeListStory
+getRepoReadConfig listIds = do
+  repoFP <- view $ hasConfig . gc_repofilepath
+  env <- liftBase $ readNodeStoryEnv repoFP
+  let g = view nse_getter env
+  liftBase $ do
+    v <- g listIds
+    readMVar v
+
+getNodeListStory :: HasNodeStory env err m
+                 => m ([NodeId] -> IO (MVar NodeListStory))
+getNodeListStory = do
+  env <- view hasNodeStory
+  pure $ view nse_getter env
+
+
+
+readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
+readNodeStoryEnv nsd = do
+  mvar  <- nodeStoryVar nsd Nothing []
+  saver <- mkNodeStorySaver nsd mvar
+  pure $ NodeStoryEnv { _nse_var = mvar
+                      , _nse_saver = saver
+                      , _nse_getter = nodeStoryVar nsd (Just mvar) }
+
+------------------------------------------------------------------------
+mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
+mkNodeStorySaver nsd mvns = mkDebounce settings
+  where
+    settings = defaultDebounceSettings
+                 { debounceAction = withMVar mvns (writeNodeStories nsd)
+                 , debounceFreq = 1 * minute
+--                 , debounceEdge = trailingEdge -- Trigger on the trailing edge
+                 }
+    minute = 60 * second
+    second = 10^(6 :: Int)
+
+nodeStoryVar :: NodeStoryDir
+             -> Maybe (MVar NodeListStory)
+             -> [NodeId]
+             -> IO (MVar NodeListStory)
+nodeStoryVar nsd Nothing ni = nodeStoryIncs nsd Nothing ni >>= newMVar
+nodeStoryVar nsd (Just mv) ni = do
+  _ <- modifyMVar_ mv $ \mv' -> (nodeStoryIncs nsd (Just mv') ni)
+  pure mv
+
+
+nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
+nodeStoryInc nsd (Just ns@(NodeStory nls)) ni = do
+  case Map.lookup ni nls of
+    Nothing -> do
+      (NodeStory nls') <- nodeStoryRead nsd ni
+      pure $ NodeStory $ Map.union nls nls'
+    Just _  -> pure ns
+nodeStoryInc nsd Nothing ni = nodeStoryRead nsd ni
+
+
+nodeStoryIncs :: NodeStoryDir
+              -> Maybe NodeListStory
+              -> [NodeId]
+              -> IO NodeListStory
+nodeStoryIncs _ Nothing    []        = pure $ NodeStory $ Map.empty
+nodeStoryIncs nsd (Just nls) ns      = foldM (\m n -> nodeStoryInc nsd (Just m) n) nls ns
+nodeStoryIncs nsd Nothing    (ni:ns) = do
+  m <- nodeStoryRead nsd ni
+  nodeStoryIncs nsd (Just m) ns
+
+
+nodeStoryDec :: NodeStoryDir
+             -> NodeListStory
+             -> NodeId
+             -> IO NodeListStory
+nodeStoryDec nsd ns@(NodeStory nls) ni = do
+  case Map.lookup ni nls of
+    Nothing -> do
+      -- we make sure the corresponding file repo is really removed
+      _ <- nodeStoryRemove nsd ni
+      pure ns
+    Just _  -> do
+      let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
+      _ <- nodeStoryRemove nsd ni
+      pure $ NodeStory ns'
+
+-- | TODO lock
+nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
+nodeStoryRead nsd ni = do
+  _repoDir <- createDirectoryIfMissing True nsd
+  let nsp = nodeStoryPath nsd ni
+  exists <- doesFileExist nsp
+  if exists
+     then deserialise <$> DBL.readFile nsp
+     else pure (initNodeStory ni)
+
+nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
+nodeStoryRemove nsd ni = do
+  let nsp = nodeStoryPath nsd ni
+  exists <- doesFileExist nsp
+  if exists
+     then removeFile nsp
+     else pure ()
+
+
+
+nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
+nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
+                          $ fmap Map.keys
+                          $ fmap _a_state
+                          $ Map.lookup ni
+                          $ _unNodeStory n
+
+------------------------------------------------------------------------
+type NodeStoryDir = FilePath
+
+writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
+writeNodeStories fp nls = do
+  _done <- mapM (writeNodeStory fp) $ splitByNode nls
+  -- printDebug "[writeNodeStories]" done
+  pure ()
+
+writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
+writeNodeStory rdfp (n, ns) = saverAction' rdfp n ns
+
+splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
+splitByNode (NodeStory m) =
+  List.map (\(n,a) -> (n, NodeStory $ Map.singleton n a)) $ Map.toList m
+
+
+saverAction' :: Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
+saverAction' repoDir nId a = do
+  withTempFile repoDir ((cs $ show nId) <> "-tmp-repo.cbor") $ \fp h -> do
+    -- printDebug "[repoSaverAction]" fp
+    DBL.hPut h $ serialise a
+    hClose h
+    renameFile fp (nodeStoryPath repoDir nId)
+
+nodeStoryPath :: NodeStoryDir -> NodeId -> FilePath
+nodeStoryPath repoDir nId = repoDir <> "/" <> filename
+  where
+    filename = "repo" <> "-" <> (cs $ show nId) <> ".cbor"
+
+
+------------------------------------------------------------------------
+-- TODO : repo Migration TODO TESTS
+{-
+repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
+repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
+
+repoToNodeListStory :: NgramsRepo -> NodeListStory
+repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
+  where
+    s' = ngramsState_migration      s
+    h' = ngramsStatePatch_migration h
+    ns = List.map (\(n,ns')
+                    -> (n, let hs = fromMaybe [] (Map.lookup n h') in
+                               Archive { _a_version = List.length hs
+                                       , _a_state = ns'
+                                       , _a_history = hs }
+                       )
+                  ) $ Map.toList s'
+
+ngramsState_migration :: NgramsState
+                      -> Map NodeId NgramsState'
+ngramsState_migration ns =
+  Map.fromListWith (Map.union) $
+  List.concat $
+    map (\(nt, nTable)
+          -> map (\(nid, table)
+                   -> (nid, Map.singleton nt table)
+                 ) $ Map.toList nTable
+        ) $ Map.toList ns
+
+
+ngramsStatePatch_migration :: [NgramsStatePatch]
+                           -> Map NodeId [NgramsStatePatch']
+ngramsStatePatch_migration np' = Map.fromListWith (<>)
+                               $ List.concat
+                               $ map toPatch np'
+  where
+    toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
+    toPatch p =
+      List.concat $
+        map (\(nt, nTable)
+              -> map (\(nid, table)
+                       -> (nid, [fst $ Patch.singleton nt table])
+                     ) $ Patch.toList nTable
+            ) $ Patch.toList p
+-}

src/Gargantext/Core/Text/List/Social/History.hs

@@ -68,5 +68,3 @@ history' types lists = (Map.map (Map.unionsWith (<>)))
           -> Map NgramsType [HashMap NgramsTerm NgramsPatch]
     toMap m = Map.map (cons . unNgramsTablePatch)
             $ unPatchMapToMap m
-
-

src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs

@@ -9,6 +9,7 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE MonoLocalBinds #-}
 {-# LANGUAGE ViewPatterns      #-}
 
 module Gargantext.Core.Viz.Phylo.Legacy.LegacyMain

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

@@ -210,4 +210,3 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
                  & unNodeStory . at listId . _Just . a_history %~ (p :)
                  & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
       saveNodeStory
-

src/Gargantext/Database/Query/Table/Node.hs

@@ -230,6 +230,9 @@ selectNodesIdWithType nt = proc () -> do
 
 ------------------------------------------------------------------------
 
+nodeExists :: (HasNodeError err) => NodeId -> Cmd err Bool
+nodeExists nId = (== [DPS.Only True])
+  <$> runPGSQuery [sql|SELECT true FROM nodes WHERE id = ? AND ?|] (nId, True)
 
 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 getNode nId = do