[nodestory] large nodestory refactoring

Get rid of that TVar completely.

gargantext.cabal

@@ -89,6 +89,7 @@ library
       Gargantext.Core.Methods.Similarities
       Gargantext.Core.NLP
       Gargantext.Core.NodeStory
+      Gargantext.Core.NodeStory.Types
       Gargantext.Core.Text
       Gargantext.Core.Text.Context
       Gargantext.Core.Text.Corpus.API
@@ -630,39 +631,6 @@ executable gargantext-admin
     , text
   default-language: Haskell2010
 
-executable gargantext-cbor2json
-  main-is: Main.hs
-  other-modules:
-      Paths_gargantext
-  hs-source-dirs:
-      bin/gargantext-cbor2json
-  default-extensions:
-      DataKinds
-      DeriveGeneric
-      FlexibleContexts
-      FlexibleInstances
-      GADTs
-      GeneralizedNewtypeDeriving
-      ImportQualifiedPost
-      MultiParamTypeClasses
-      NamedFieldPuns
-      NoImplicitPrelude
-      OverloadedStrings
-      RankNTypes
-      RecordWildCards
-      StrictData
-  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 -Wmissing-signatures
-  build-depends:
-      aeson ^>= 1.5.6.0
-    , base ^>= 4.14.3
-    , bytestring ^>= 0.10.12.0
-    , extra ^>= 1.7.9
-    , gargantext
-    , gargantext-prelude
-    , serialise ^>= 0.2.4.0
-    , text ^>= 1.2.4.1
-  default-language: Haskell2010
-
 executable gargantext-cli
   main-is: Main.hs
   other-modules:

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.hs

@@ -40,42 +40,15 @@ TODO:
 - charger les listes
 -}
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell   #-}
 
 module Gargantext.Core.NodeStory
-  ( HasNodeStory
-  , HasNodeStoryEnv
-  , hasNodeStory
-  , HasNodeStoryVar
-  , hasNodeStoryVar
-  , HasNodeStoryImmediateSaver
-  , hasNodeStoryImmediateSaver
-  , HasNodeArchiveStoryImmediateSaver
-  , hasNodeArchiveStoryImmediateSaver
-  , NodeStory(..)
-  , NgramsStatePatch'
-  , NodeListStory
-  , ArchiveList
-  , initNodeListStoryMock
-  , NodeStoryEnv(..)
-  , initNodeStory
-  , nse_getter
-  , nse_saver_immediate
-  , nse_archive_saver_immediate
-  , nse_var
-  , unNodeStory
+  ( module Gargantext.Core.NodeStory.Types
   , getNodesArchiveHistory
   , Archive(..)
-  , initArchive
-  , archiveAdvance
-  , unionArchives
-  , a_history
-  , a_state
-  , a_version
   , nodeExists
   , runPGSQuery
   , runPGSAdvisoryLock
@@ -84,7 +57,7 @@ module Gargantext.Core.NodeStory
   , getNodesIdWithType
   , fromDBNodeStoryEnv
   , upsertNodeStories
-  , getNodeStory
+  -- , getNodeStory
   , nodeStoriesQuery
   , currentVersion
   , archiveStateFromList
@@ -92,208 +65,29 @@ module Gargantext.Core.NodeStory
   , fixNodeStoryVersions )
 where
 
-import Codec.Serialise.Class
-import Control.Lens (makeLenses, Getter, (^.), (.~), (%~), non, _Just, at, view)
+import Control.Lens ((^.), (.~), (%~), non, _Just, at, view)
 import Control.Monad.Except
-import Control.Monad.Reader
-import Data.Aeson hiding ((.=), decode)
 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 Data.Pool (Pool, withResource)
-import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
-import Data.Semigroup
 import Data.Set qualified as Set
 import Database.PostgreSQL.Simple qualified as PGS
-import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.ToField qualified as PGS
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
-import GHC.Conc (TVar, newTVar, readTVar, writeTVar)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core (toDBid)
+import Gargantext.Core.NodeStory.Types
 import Gargantext.Core.Types (ListId, NodeId(..), NodeType)
-import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Admin.Config ()
-import Gargantext.Database.Prelude (DbCmd', HasConnectionPool(..))
+import Gargantext.Database.Prelude (HasConnectionPool(..))
 import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude hiding (to)
 import Gargantext.Prelude.Database
-import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
-
-------------------------------------------------------------------------
-data NodeStoryEnv = NodeStoryEnv
-  { _nse_var    :: !(TVar NodeListStory)
-  , _nse_saver_immediate :: !(IO ())
-  , _nse_archive_saver_immediate :: !(NodeListStory -> IO NodeListStory)
-  , _nse_getter :: !([NodeId] -> IO (TVar NodeListStory))
-  --, _nse_cleaner :: !(IO ()) -- every 12 hours: cleans the repos of unused NodeStories
-  -- , _nse_lock  :: !FileLock -- TODO (it depends on the option: if with database or file only)
-  }
-  deriving (Generic)
-
-type HasNodeStory env err m = ( DbCmd' env err m
-                              , MonadReader env m
-                              , MonadError  err m
-                              , HasNodeStoryEnv env
-                              , HasNodeError err
-                              )
-
-class (HasNodeStoryVar env, HasNodeStoryImmediateSaver env)
-  => HasNodeStoryEnv env where
-    hasNodeStory :: Getter env NodeStoryEnv
-
-class HasNodeStoryVar env where
-  hasNodeStoryVar :: Getter env ([NodeId] -> IO (TVar NodeListStory))
-
-class HasNodeStoryImmediateSaver env where
-  hasNodeStoryImmediateSaver :: Getter env (IO ())
-
-class HasNodeArchiveStoryImmediateSaver env where
-  hasNodeArchiveStoryImmediateSaver :: Getter env (NodeListStory -> IO NodeListStory)
-
-------------------------------------------------------------------------
-
-{- | 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 (<>)
-
--- This is not a typical Semigroup instance. The state is not
--- appended, instead it is replaced with the second entry. This is
--- because state changes with each version. We have to take into
--- account the removal of terms as well.
--- instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
---   (<>) (Archive { _a_history = p }) (Archive { _a_version = v'
---                                              , _a_state = s'
---                                              , _a_history = p' }) =
---     Archive { _a_version = v'
---             , _a_state = s'
---             , _a_history = p' <> p }
--- instance (Monoid s, Semigroup p) => Monoid (Archive s p) where
---   mempty = Archive { _a_version = 0
---                    , _a_state = mempty
---                    , _a_history = [] }
-instance (FromJSON s, FromJSON p) => FromJSON (Archive s p) where
-  parseJSON = genericParseJSON $ unPrefix "_a_"
-instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
-  toJSON     = genericToJSON     $ unPrefix "_a_"
-  toEncoding = genericToEncoding $ unPrefix "_a_"
-
--- | This is the normal way to update archive state, bumping the
--- version and history. Resulting state is taken directly from new
--- archive, omitting old archive completely.
-archiveAdvance :: (Semigroup s, Semigroup p) => Archive s p -> Archive s p -> Archive s p
-archiveAdvance aOld aNew = aNew { _a_history = _a_history aNew <> _a_history aOld }
-
--- | This is to merge archive states.
-unionArchives :: (Semigroup s, Semigroup p) => Archive s p -> Archive s p -> Archive s p
-unionArchives aOld aNew = aNew { _a_state = _a_state aOld <> _a_state aNew
-                               , _a_history = _a_history aNew <> _a_history aOld }
-
-
-------------------------------------------------------------------------
-initNodeStory :: (Monoid s, Semigroup p) => NodeId -> NodeStory s p
-initNodeStory ni = NodeStory $ Map.singleton ni initArchive
-
-initArchive :: (Monoid s, Semigroup p) => Archive s p
-initArchive = Archive { _a_version = 0
-                      , _a_state = mempty
-                      , _a_history = [] }
-
-initNodeListStoryMock :: NodeListStory
-initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
-  where
-    nodeListId = 0
-    archive = Archive { _a_version = 0
-                      , _a_state = ngramsTableMap
-                      , _a_history = [] }
-    ngramsTableMap = Map.singleton TableNgrams.NgramsTerms
-                   $ Map.fromList
-                   [ (n ^. ne_ngrams, ngramsElementToRepo n)
-                   | n <- mockTable ^. _NgramsTable
-                   ]
-
-------------------------------------------------------------------------
-------------------------------------------------------------------------
--- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
-makeLenses ''NodeStoryEnv
-makeLenses ''NodeStory
-makeLenses ''Archive
-
-----------------------------------------------------------------------
-data NodeStoryPoly nid v ngtid ngid nre =
-  NodeStoryDB { node_id             :: !nid
-              , version             :: !v
-              , ngrams_type_id      :: !ngtid
-              , ngrams_id           :: !ngid
-              , ngrams_repo_element :: !nre }
-  deriving (Eq)
-
-data NodeStoryArchivePoly nid a =
-  NodeStoryArchiveDB { a_node_id :: !nid
-                     , archive   :: !a }
-  deriving (Eq)
-
-$(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
-$(makeAdaptorAndInstance "pNodeArchiveStory" ''NodeStoryArchivePoly)
-
--- type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlJsonb)
--- type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlJsonb)
-
--- type NodeStoryArchiveWrite = NodeStoryArchivePoly (Column SqlInt4) (Column SqlJsonb)
--- type NodeStoryArchiveRead = NodeStoryArchivePoly (Column SqlInt4) (Column SqlJsonb)
-
-type ArchiveList = Archive NgramsState' NgramsStatePatch'
 
 -- DB stuff
 
@@ -366,8 +160,8 @@ insertNodeArchiveHistory c nodeId version (h:hs) = do
                 VALUES (?, ?, ?, ?, ?)
                 |]
 
-getNodeStory :: PGS.Connection -> NodeId -> IO NodeListStory
-getNodeStory c nId = do
+getNodeStory' :: PGS.Connection -> NodeId -> IO ArchiveList
+getNodeStory' c nId = do
   --res <- withResource pool $ \c -> runSelect c query :: IO [NodeStoryPoly NodeId Version Int Int NgramsRepoElement]
   res <- runPGSQuery c nodeStoriesQuery (PGS.Only $ PGS.toField nId) :: IO [(Version, TableNgrams.NgramsType, NgramsTerm, NgramsRepoElement)]
   -- We have multiple rows with same node_id and different (ngrams_type_id, ngrams_id).
@@ -390,12 +184,19 @@ getNodeStory c nId = do
     pure ()
 -}
 
-  pure $ NodeStory $ Map.singleton nId $ foldl combine initArchive dbData
+  pure $ foldl combine initArchive dbData
   where
     -- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine`
     combine a1 a2 = a1 & a_state %~ combineState (a2 ^. a_state)
                        & a_version .~ (a2 ^. a_version)  -- version should be updated from list, not taken from the empty Archive
 
+
+getNodeStory :: PGS.Connection -> NodeId -> IO NodeListStory
+getNodeStory c nId = do
+  a <- getNodeStory' c nId
+  pure $ NodeStory $ Map.singleton nId a
+
+
 nodeStoriesQuery :: PGS.Query
 nodeStoriesQuery = [sql| SELECT version, ngrams_type_id, terms, ngrams_repo_element
                            FROM node_stories
@@ -403,9 +204,6 @@ nodeStoriesQuery = [sql| SELECT version, ngrams_type_id, terms, ngrams_repo_elem
                            WHERE node_id = ?
                            |]
 
-type ArchiveStateList = [(TableNgrams.NgramsType, NgramsTerm, NgramsRepoElement)]
-type ArchiveStateSet = Set.Set (TableNgrams.NgramsType, NgramsTerm)
-
 -- |Functions to convert archive state (which is a `Map NgramsType
 --  (Map NgramsTerm NgramsRepoElement`)) to/from a flat list
 archiveStateToList :: NgramsState' -> ArchiveStateList
@@ -523,13 +321,6 @@ updateNodeStory c nodeId currentArchive newArchive = do
   --                   , 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 }
-
 upsertNodeStories :: PGS.Connection -> NodeId -> ArchiveList -> IO ()
 upsertNodeStories c nodeId newArchive = do
   -- printDebug "[upsertNodeStories] START nId" nId
@@ -562,10 +353,6 @@ updateNodeStoryVersion c nodeId newArchive = do
                 WHERE node_id = ?
                 AND ngrams_type_id = ?|]
 
-writeNodeStories :: PGS.Connection -> NodeListStory -> IO ()
-writeNodeStories c (NodeStory nls) = do
-  mapM_ (\(nId, a) -> upsertNodeStories c nId a) $ Map.toList nls
-
 -- | Returns a `NodeListStory`, updating the given one for given `NodeId`
 nodeStoryInc :: PGS.Connection -> NodeListStory -> NodeId -> IO NodeListStory
 nodeStoryInc c ns@(NodeStory nls) nId = do
@@ -575,34 +362,10 @@ nodeStoryInc c ns@(NodeStory nls) nId = do
       pure $ NodeStory $ Map.unionWith archiveAdvance nls' nls
     Just _ -> pure ns
 
-nodeStoryIncrementalRead :: PGS.Connection -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
-nodeStoryIncrementalRead _ Nothing [] = pure $ NodeStory $ Map.empty
-nodeStoryIncrementalRead c Nothing (ni:ns) = do
-  m <- getNodeStory c ni
-  nodeStoryIncrementalRead c (Just m) ns
-nodeStoryIncrementalRead c (Just nls) ns = foldM (\m n -> nodeStoryInc c m n) nls 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'
-------------------------------------
-
 -- | NgramsRepoElement contains, in particular, `nre_list`,
 -- `nre_parent` and `nre_children`. We want to make sure that all
 -- children entries (i.e. ones that have `nre_parent`) have the same
 -- `list` as their parent entry.
-fixChildrenTermTypes :: NodeListStory -> NodeListStory
-fixChildrenTermTypes (NodeStory nls) =
-  NodeStory $ Map.fromList [ (nId, a & a_state %~ fixChildrenInNgramsStatePatch)
-                           | (nId, a) <- Map.toList nls ]
-
 fixChildrenInNgramsStatePatch :: NgramsState' -> NgramsState'
 fixChildrenInNgramsStatePatch ns = archiveStateFromList $ nsParents <> nsChildrenFixed
   where
@@ -623,11 +386,6 @@ fixChildrenInNgramsStatePatch ns = archiveStateFromList $ nsParents <> nsChildre
 -- | Sometimes, when we upload a new list, a child can be left without
 -- a parent. Find such ngrams and set their 'root' and 'parent' to
 -- 'Nothing'.
-fixChildrenWithNoParent :: NodeListStory -> NodeListStory
-fixChildrenWithNoParent (NodeStory nls) =
-  NodeStory $ Map.fromList [ (nId, a & a_state %~ fixChildrenWithNoParentStatePatch)
-                           | (nId, a) <- Map.toList nls ]
-
 fixChildrenWithNoParentStatePatch :: NgramsState' -> NgramsState'
 fixChildrenWithNoParentStatePatch ns = archiveStateFromList $ nsParents <> nsChildrenFixed
   where
@@ -654,50 +412,37 @@ fixChildrenWithNoParentStatePatch ns = archiveStateFromList $ nsParents <> nsChi
 
 fromDBNodeStoryEnv :: Pool PGS.Connection -> IO NodeStoryEnv
 fromDBNodeStoryEnv pool = do
-  tvar <- nodeStoryVar pool Nothing []
-  let saver_immediate = do
-        ns <- atomically $
-              readTVar tvar
-              -- fix children so their 'list' is the same as their parents'
-              >>= pure . fixChildrenTermTypes
-              -- fix children that don't have a parent anymore
-              >>= pure . fixChildrenWithNoParent
-              >>= writeTVar tvar
-              >> readTVar tvar
+  -- tvar <- nodeStoryVar pool Nothing []
+  let saver_immediate nId a = do
+        -- ns <- atomically $
+        --       readTVar tvar
+        --       -- fix children so their 'list' is the same as their parents'
+        --       >>= pure . fixChildrenTermTypes
+        --       -- fix children that don't have a parent anymore
+        --       >>= pure . fixChildrenWithNoParent
+        --       >>= writeTVar tvar
+        --       >> readTVar tvar
         withResource pool $ \c -> do
           --printDebug "[mkNodeStorySaver] will call writeNodeStories, ns" ns
-          writeNodeStories c ns
-  let archive_saver_immediate ns@(NodeStory nls) = withResource pool $ \c -> do
-        mapM_ (\(nId, a) -> do
-                  insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
-              ) $ Map.toList nls
-        pure $ clearHistory ns
+          -- writeNodeStories c $ fixChildrenWithNoParent $ fixChildrenTermTypes ns
+          upsertNodeStories c nId $
+            a & a_state %~ (fixChildrenInNgramsStatePatch . fixChildrenWithNoParentStatePatch)
+  let archive_saver_immediate nId a = withResource pool $ \c -> do
+        insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
+        pure $ a & a_history .~ []
+        -- mapM_ (\(nId, a) -> do
+        --           insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
+        --       ) $ Map.toList nls
+        -- pure $ clearHistory ns
         
-  pure $ NodeStoryEnv { _nse_var    = tvar
-                      , _nse_saver_immediate = saver_immediate
+  pure $ NodeStoryEnv { _nse_saver_immediate = saver_immediate
                       , _nse_archive_saver_immediate = archive_saver_immediate
-                      , _nse_getter = nodeStoryVar pool (Just tvar)
+                      , _nse_getter = \nId -> withResource pool $ \c ->
+                          getNodeStory' c nId
+                      , _nse_getter_multi = \nIds -> withResource pool $ \c ->
+                          foldM (\m nId -> nodeStoryInc c m nId) (NodeStory Map.empty) nIds
                       }
 
-nodeStoryVar :: Pool PGS.Connection
-             -> Maybe (TVar NodeListStory)
-             -> [NodeId]
-             -> IO (TVar NodeListStory)
-nodeStoryVar pool Nothing nIds = do
-  state' <- withResource pool $ \c -> nodeStoryIncrementalRead c Nothing nIds
-  atomically $ newTVar state'
-nodeStoryVar pool (Just tv) nIds = do
-  nls <- atomically $ readTVar tv
-  nls' <- withResource pool
-      $ \c -> nodeStoryIncrementalRead c (Just nls) nIds
-  _ <- atomically $ writeTVar tv nls'
-  pure tv
-
-clearHistory :: NodeListStory -> NodeListStory
-clearHistory (NodeStory ns) = NodeStory $ ns & (traverse . a_history) .~ emptyHistory
-  where
-    emptyHistory = [] :: [NgramsStatePatch']
-
 currentVersion :: (HasNodeStory env err m) => ListId -> m Version
 currentVersion listId = do
   pool <- view connPool
@@ -748,3 +493,72 @@ fixNodeStoryVersions = do
           _ <- runPGSExecute c updateVerQuery (maxVersion, nId, ngramsType)
           pure ()
         _ -> panicTrace "Should get only 1 result!"
+
+-----------------------------------------
+
+-- DEPRECATED
+
+
+-- nodeStoryVar :: Pool PGS.Connection
+--              -> Maybe (TVar NodeListStory)
+--              -> [NodeId]
+--              -> IO (TVar NodeListStory)
+-- nodeStoryVar pool Nothing nIds = do
+--   state' <- withResource pool $ \c -> nodeStoryIncrementalRead c Nothing nIds
+--   atomically $ newTVar state'
+-- nodeStoryVar pool (Just tv) nIds = do
+--   nls <- atomically $ readTVar tv
+--   nls' <- withResource pool
+--       $ \c -> nodeStoryIncrementalRead c (Just nls) nIds
+--   _ <- atomically $ writeTVar tv nls'
+--   pure tv
+
+-- clearHistory :: NodeListStory -> NodeListStory
+-- clearHistory (NodeStory ns) = NodeStory $ ns & (traverse . a_history) .~ emptyHistory
+--   where
+--     emptyHistory = [] :: [NgramsStatePatch']
+
+
+-- fixChildrenWithNoParent :: NodeListStory -> NodeListStory
+-- fixChildrenWithNoParent (NodeStory nls) =
+--   NodeStory $ Map.fromList [ (nId, a & a_state %~ fixChildrenWithNoParentStatePatch)
+--                            | (nId, a) <- Map.toList nls ]
+
+
+-- fixChildrenTermTypes :: NodeListStory -> NodeListStory
+-- fixChildrenTermTypes (NodeStory nls) =
+--   NodeStory $ Map.fromList [ (nId, a & a_state %~ fixChildrenInNgramsStatePatch)
+--                            | (nId, a) <- Map.toList nls ]
+
+
+-- nodeStoryIncrementalRead :: PGS.Connection -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
+-- nodeStoryIncrementalRead _ Nothing [] = pure $ NodeStory Map.empty
+-- nodeStoryIncrementalRead c Nothing (ni:ns) = do
+--   m <- getNodeStory c ni
+--   nodeStoryIncrementalRead c (Just m) ns
+-- nodeStoryIncrementalRead c (Just nls) ns = foldM (\m n -> nodeStoryInc c m n) nls 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'
+------------------------------------
+
+
+-- writeNodeStories :: PGS.Connection -> NodeListStory -> IO ()
+-- writeNodeStories c (NodeStory nls) = do
+--   mapM_ (\(nId, a) -> upsertNodeStories c nId a) $ Map.toList nls
+
+
+-- 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 }

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

@@ -17,16 +17,16 @@ Portability : POSIX
 module Gargantext.Database.Action.Flow.List
     where
 
-import Control.Lens ((^.), (+~), (%~), at, (.~), _Just)
+import Control.Lens ((^.), (+~), (%~), at, (.~))
 import Control.Monad.Reader
 import Data.List qualified as List
 import Data.Map.Strict (toList)
 import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
 import Gargantext.API.Ngrams (saveNodeStory)
-import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
+import Gargantext.API.Ngrams.Tools (getNodeStory)
 import Gargantext.API.Ngrams.Types
-import Gargantext.Core.NodeStory
+import Gargantext.Core.NodeStory (HasNodeStory, a_history, a_state, a_version)
 import Gargantext.Core.Types (HasValidationError(..), assertValid)
 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
 import Gargantext.Database.Admin.Types.Node
@@ -34,7 +34,6 @@ 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
@@ -201,11 +200,14 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
       -- The modifyMVar_ would test the patch with applicable first.
       -- If valid the rest would be atomic and no merge is required.
       -}
-      var <- getNodeStoryVar [listId]
-      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
+      a <- getNodeStory listId
+      let a' = a & a_version +~ 1
+                 & a_history %~ (p :)
+                 & 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 listId a'

test/Test/Database/Operations/NodeStory.hs

@@ -20,9 +20,9 @@ import Data.Map.Strict.Patch qualified as PM
 import Data.Set qualified as Set
 import Database.PostgreSQL.Simple qualified as PSQL
 import Database.PostgreSQL.Simple.SqlQQ
-import Gargantext.API.Ngrams (commitStatePatch, mSetFromList, setListNgrams, saveNodeStoryImmediate)
+import Gargantext.API.Ngrams (commitStatePatch, mSetFromList, setListNgrams, saveNodeStory)
 import Gargantext.API.Ngrams.Types (MSet(..), NgramsPatch(..), NgramsRepoElement(..), NgramsTerm(..), Versioned(..), mkNgramsTablePatch, nre_children, nre_list, nre_parent, nre_root)
-import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
+import Gargantext.API.Ngrams.Tools (getNodeStory)
 import Gargantext.Core.NodeStory hiding (runPGSQuery)
 import Gargantext.Core.Types.Individu
 import Gargantext.Core.Types (ListType(..), ListId, NodeId, UserId)
@@ -35,13 +35,12 @@ import Gargantext.Database.Query.Tree.Root
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
 import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Prelude
-import GHC.Conc (TVar, readTVar)
 import Test.Database.Types
 import Test.Hspec.Expectations
 import Test.Tasty.HUnit
 
 
-commonInitialization :: TestMonad ( UserId, NodeId, ListId, TVar NodeListStory )
+commonInitialization :: TestMonad ( UserId, NodeId, ListId, ArchiveList )
 commonInitialization = do
   let user = UserName userMaster
   parentId <- getRootId user
@@ -52,9 +51,9 @@ commonInitialization = do
 
   listId <- getOrMkList corpusId userId
 
-  v <- getNodeStoryVar [listId]
+  a <- getNodeStory listId
 
-  pure $ (userId, corpusId, listId, v)
+  pure $ (userId, corpusId, listId, a)
 
 
 initArchiveList :: ArchiveList
@@ -90,7 +89,7 @@ simpleChildTerm = ( simpleChildTerm'
 createListTest :: TestEnv -> Assertion
 createListTest env = do
   flip runReaderT env $ runTestMonad $ do
-    (userId, corpusId, listId, _v) <- commonInitialization
+    (userId, corpusId, listId, _a) <- commonInitialization
 
     listId' <- getOrMkList corpusId userId
     
@@ -100,28 +99,32 @@ createListTest env = do
 queryNodeStoryTest :: TestEnv -> Assertion
 queryNodeStoryTest env = do
   flip runReaderT env $ runTestMonad $ do
-    (_userId, _corpusId, listId, v) <- commonInitialization
+    (_userId, _corpusId, listId, a) <- commonInitialization
+
+    liftIO $ do
+      a `shouldBe` initArchiveList
+
+    saveNodeStory listId a
+
+    a' <- getNodeStory listId
 
-    saveNodeStoryImmediate
-    
     liftIO $ do
-      ns <- atomically $ readTVar v
-      ns `shouldBe` (NodeStory $ Map.singleton listId initArchiveList)
+      a' `shouldBe` a
   
 
 insertNewTermsToNodeStoryTest :: TestEnv -> Assertion
 insertNewTermsToNodeStoryTest env = do
   flip runReaderT env $ runTestMonad $ do
-    (_userId, _corpusId, listId, v) <- commonInitialization
+    (_userId, _corpusId, listId, _a) <- commonInitialization
 
     let (terms, nre) = simpleTerm
     let nls = Map.singleton terms nre
     setListNgrams listId NgramsTerms nls
-    
+
+    a <- getNodeStory listId
+
     liftIO $ do
-      ns <- atomically $ readTVar v
-      ns `shouldBe` (NodeStory $ Map.singleton listId
-                       (initArchiveList { _a_state = Map.singleton NgramsTerms nls }))
+      a `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nls })
     -- check that the ngrams are in the DB as well
     ngramsMap <- selectNgramsId [unNgramsTerm terms]
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` [unNgramsTerm terms]
@@ -139,7 +142,7 @@ insertNewTermsToNodeStoryTest env = do
 insertNewTermsWithChildrenToNodeStoryTest :: TestEnv -> Assertion
 insertNewTermsWithChildrenToNodeStoryTest env = do
   flip runReaderT env $ runTestMonad $ do
-    (_userId, _corpusId, listId, v) <- commonInitialization
+    (_userId, _corpusId, listId, _a) <- commonInitialization
 
     let (tParent, nreParent) = simpleParentTerm
     let (tChild, nreChild) = simpleChildTerm
@@ -148,10 +151,10 @@ insertNewTermsWithChildrenToNodeStoryTest env = do
     let nls = Map.fromList [(tParent, nreParent), (tChild, nreChild)]
     setListNgrams listId NgramsTerms nls
 
+    a <- getNodeStory listId
+
     liftIO $ do
-      ns <- atomically $ readTVar v
-      ns `shouldBe` (NodeStory $ Map.singleton listId 
-                      (initArchiveList { _a_state = Map.singleton NgramsTerms nls }))
+      a `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nls })
 
     -- `setListNgrams` calls saveNodeStory already so we should have
     -- the terms in the DB by now
@@ -178,7 +181,7 @@ insertNewTermsWithChildrenToNodeStoryTest env = do
 insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest :: TestEnv -> Assertion
 insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest env = do
   flip runReaderT env $ runTestMonad $ do
-    (_userId, _corpusId, listId, v) <- commonInitialization
+    (_userId, _corpusId, listId, _a) <- commonInitialization
 
     let (tParent, nreParent) = simpleParentTerm
     let (tChild, nreChildGoodType) = simpleChildTerm
@@ -190,10 +193,10 @@ insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest env = do
     
     setListNgrams listId NgramsTerms nls
 
+    a <- getNodeStory listId
+
     liftIO $ do
-      ns <- atomically $ readTVar v
-      ns `shouldBe` (NodeStory $ Map.singleton listId 
-                      (initArchiveList { _a_state = Map.singleton NgramsTerms nlsWithChildFixed }))
+      a `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nlsWithChildFixed })
 
     ngramsMap <- selectNgramsId terms
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` terms
@@ -216,16 +219,16 @@ insertNodeStoryChildrenWithDifferentNgramsTypeThanParentTest env = do
 setListNgramsUpdatesNodeStoryTest :: TestEnv -> Assertion
 setListNgramsUpdatesNodeStoryTest env = do
   flip runReaderT env $ runTestMonad $ do
-    (_userId, _corpusId, listId, v) <- commonInitialization
+    (_userId, _corpusId, listId, _a) <- commonInitialization
 
     let (terms, nre) = simpleTerm
     let nls = Map.singleton terms nre
     setListNgrams listId NgramsTerms nls
-    
+
+    a <- getNodeStory listId
+
     liftIO $ do
-      ns <- atomically $ readTVar v
-      ns `shouldBe` (NodeStory $ Map.singleton listId
-                       (initArchiveList { _a_state = Map.singleton NgramsTerms nls }))
+      a `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nls })
     -- check that the ngrams are in the DB as well
     ngramsMap <- selectNgramsId [unNgramsTerm terms]
     liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` [unNgramsTerm terms]
@@ -238,27 +241,27 @@ setListNgramsUpdatesNodeStoryTest env = do
     let terms2 = "WORLD"
     let nls2 = Map.singleton (NgramsTerm terms2) nre2
     setListNgrams listId NgramsTerms nls2
-                                        
+
+    a' <- getNodeStory listId
+
     liftIO $ do
-      ns <- atomically $ readTVar v
-      ns `shouldBe` (NodeStory $ Map.singleton listId
-                       (initArchiveList { _a_state = Map.singleton NgramsTerms $ nls <> nls2 }))
+      a' `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms $ nls <> nls2 })
 
 
 setListNgramsUpdatesNodeStoryWithChildrenTest :: TestEnv -> Assertion
 setListNgramsUpdatesNodeStoryWithChildrenTest env = do
   flip runReaderT env $ runTestMonad $ do
-    (_userId, _corpusId, listId, v) <- commonInitialization
+    (_userId, _corpusId, listId, _a) <- commonInitialization
 
     let (tChild, nreChild) = simpleChildTerm
     let (tParent, nreParent) = simpleParentTerm
     let nls = Map.fromList [(tParent, nreParent), (tChild, nreChild)]
     setListNgrams listId NgramsTerms nls
-    
+
+    a <- getNodeStory listId
+
     liftIO $ do
-      ns <- atomically $ readTVar v
-      ns `shouldBe` (NodeStory $ Map.singleton listId
-                       (initArchiveList { _a_state = Map.singleton NgramsTerms nls }))
+      a `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nls })
 
     -- OK, now we substitute parent with no children, the parent of
     -- 'nreChild' should become Nothing
@@ -270,22 +273,20 @@ setListNgramsUpdatesNodeStoryWithChildrenTest env = do
                                , _nre_root = Nothing }
     let nlsNew = Map.fromList [(tParent, nreParentNew), (tChild, nreChildNew)]
 
+    a' <- getNodeStory listId
+
     liftIO $ do
-      ns <- atomically $ readTVar v
-      ns `shouldBe` (NodeStory $ Map.singleton listId
-                       (initArchiveList { _a_state = Map.singleton NgramsTerms nlsNew }))
+      a' `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nlsNew })
 
 
 commitPatchSimpleTest :: TestEnv -> Assertion
 commitPatchSimpleTest env = do
   flip runReaderT env $ runTestMonad $ do
-    (_userId, _corpusId, listId, v) <- commonInitialization
+    (_userId, _corpusId, listId, a) <- commonInitialization
 
     -- initially, the node story table is empty
     liftIO $ do
-      ns <- atomically $ readTVar v
-      ns `shouldBe` (NodeStory $ Map.singleton listId
-                       (initArchiveList { _a_state = Map.empty }))
+      a `shouldBe` (initArchiveList { _a_state = Map.empty })
 
     let (term, nre) = simpleTerm
     let tPatch = NgramsReplace { _patch_old = Nothing
@@ -298,9 +299,9 @@ commitPatchSimpleTest env = do
     _patchApplied <- commitStatePatch listId patch
 
     let nls = Map.fromList [(term, nre)]
-    
+
+    a' <- getNodeStory listId
+
     liftIO $ do
-      ns <- atomically $ readTVar v
-      ns `shouldBe` (NodeStory $ Map.singleton listId
-                       (initArchiveList { _a_state = Map.singleton NgramsTerms nls
-                                        , _a_version = ver + 1 }))
+      a' `shouldBe` (initArchiveList { _a_state = Map.singleton NgramsTerms nls
+                                     , _a_version = ver + 1 })

test/Test/Database/Types.hs

@@ -115,10 +115,6 @@ instance HasMail TestEnv where
 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