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