Merge branch '303-dev-node-story-refactoring' into dev-tests-refactor

.gitignore

@@ -38,3 +38,5 @@ tmp*repo*json
 data
 
 devops/docker/js-cache
+
+cabal.project.local
\ No newline at end of file

CHANGELOG.md

+## Version 0.0.6.9.9.9.6
+
+* [FIX] Graph Order 2B to remove Order 2A.
+
 ## Version 0.0.6.9.9.9.5
 
 * [BACK][CI][Improving CI](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/247)

README.md

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

cabal.project

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

src/Gargantext/API.hs

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

src/Gargantext/API/Admin/EnvTypes.hs

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

src/Gargantext/API/Dev.hs

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

src/Gargantext/API/Ngrams.hs

@@ -59,7 +59,7 @@ module Gargantext.API.Ngrams
   , r_state
   , r_history
   , NgramsRepoElement(..)
-  , saveNodeStoryImmediate
+  , saveNodeStory
   , initRepo
 
   , TabType(..)
@@ -86,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
@@ -104,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)
@@ -122,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)
 
 {-
@@ -172,14 +171,11 @@ mkChildrenGroups addOrRem nt patches =
 
 ------------------------------------------------------------------------
 
-saveNodeStoryImmediate :: ( MonadReader env m, MonadBase IO m, HasNodeStoryImmediateSaver env )
-                       => m ()
-saveNodeStoryImmediate = do
+saveNodeStory :: ( MonadReader env m, MonadBase IO m, HasNodeStoryImmediateSaver env )
+              => NodeId -> ArchiveList -> m ()
+saveNodeStory nId a = 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
@@ -245,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
-  saveNodeStoryImmediate
+  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]
@@ -281,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)
@@ -316,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
@@ -342,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
 
 
 
@@ -363,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
 
@@ -491,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/Methods/Similarities/Accelerate/Distributional.hs

@@ -203,8 +203,8 @@ logDistributional' o n m' = trace ("logDistributional'") result
     -- Matrix nxn. mi = [m_{i,j}]_{i,j} where 
     -- m_{i,j} = 0 if n_{i,j} = 0 or i = j, 
     -- m_{i,j} = log(to * n_{i,j} / s_{i,j}) otherwise.
-    mi = (.*) (matrixEye n) 
-        (map (lift1 (\x -> cond (x == 0) 0 (log (o + x * to)))) ((./) m ss))
+    mi = (.*) (matrixEye n)
+              (map (lift1 (\x -> let x' = o + x * to in cond (x' < 1) 0 (log x'))) ((./) m ss))
     -- mi_nnz :: Int
     -- mi_nnz = flip indexArray Z . run $
     --   foldAll (+) 0 $ map (\a -> ifThenElse (abs a < 10^(-6 :: Exp Int)) 0 1) mi

src/Gargantext/Core/NodeStory/Types.hs

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

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 (saveNodeStoryImmediate)
-import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
+import Gargantext.API.Ngrams (saveNodeStory)
+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,15 @@ 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
-      saveNodeStoryImmediate
+      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'
+

src/Gargantext/Database/Action/Search.hs

@@ -95,7 +95,7 @@ searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
     queryDocInDatabase :: ParentId -> Text -> O.Select (Column SqlInt4, Column SqlJsonb)
     queryDocInDatabase _p q = proc () -> do
         row <- queryNodeSearchTable -< ()
-        restrict -< (_ns_search row)    @@ (sqlToTSQuery (unpack q))
+        restrict -< (_ns_search row)    @@ (sqlPlainToTSQuery (unpack q))
         restrict -< (_ns_typename row) .== (sqlInt4 $ toDBid NodeDocument)
         returnA  -< (_ns_id row, _ns_hyperdata row)
 

test/Test/Database/Operations.hs

@@ -65,6 +65,7 @@ tests = sequential $ aroundAll withTestDBWithTriggers $ describe "Database" $ do
       it "Can perform search by author in documents" corpusSearch02
       it "Can perform more complex searches using the boolean API" corpusSearch03
       it "Can correctly count doc score" corpusScore01
+      it "Can perform search with spaces for doc in db" corpusSearchDB01
         
 nodeStoryTests :: Spec
 nodeStoryTests = sequential $

test/Test/Database/Operations/DocumentSearch.hs

@@ -210,3 +210,16 @@ corpusScore01 env = do
 
     liftIO $ do
       map facetDoc_score results `shouldBe` [Just 0.0, Just 0.0]
+
+-- | Check that we support search with tsquery
+corpusSearchDB01 :: TestEnv -> Assertion
+corpusSearchDB01 env = do
+  flip runReaderT env $ runTestMonad $ do
+
+    parentId <- getRootId (UserName userMaster)
+    [corpus] <- getCorporaWithParentId parentId
+
+    results <- searchDocInDatabase (_node_id corpus) ("first second")
+
+    liftIO $ do
+      length results `shouldBe` 0 -- doesn't exist, we just check that proper to_tsquery is called

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

@@ -131,10 +131,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