WIP (refact HasNodeStoryEnv)

src/Gargantext/API/Ngrams/Tools.hs

@@ -39,14 +39,8 @@ mergeNgramsElement _neOld neNew = neNew
 type RootTerm = NgramsTerm
 
 
-getRepo :: HasNodeStory env err m
-         => [ListId] -> m (DBQuery err x NodeListStory)
-getRepo listIds = do
-  f <- getNodeListStoryMulti
-  pure $ f listIds
-  -- v  <- liftBase $ f listIds
-  -- v' <- liftBase $ atomically $ readTVar v
-  -- pure $ v'
+getRepo :: NodeStoryEnv err -> [ListId] -> DBQuery err x NodeListStory
+getRepo env listIds = getNodeListStoryMulti env listIds
 
 
 repoSize :: Ord k1 => NodeStory (Map.Map k1 (Map.Map k2 a)) p
@@ -59,27 +53,19 @@ repoSize repo node_id = Map.map Map.size state'
                    . a_state
 
 
-getNodeStory :: HasNodeStory env err m => ListId -> m (DBQuery err x ArchiveList)
-getNodeStory l = do
-  f <- getNodeListStory
-  pure $ f l
-  -- v  <- liftBase $ f l
-  -- pure v
+getNodeStory :: NodeStoryEnv err -> ListId -> DBQuery err x ArchiveList
+getNodeStory env l = getNodeListStory env l
 
+getNodeListStory :: NodeStoryEnv err
+                 -> NodeId
+                 -> DBQuery err x ArchiveList
+getNodeListStory env = view nse_getter env
 
-getNodeListStory :: HasNodeStory env err m
-                 => m (NodeId -> DBQuery err x ArchiveList)
-getNodeListStory = do
-  env <- view hasNodeStory
-  pure $ view nse_getter env
-
-
-getNodeListStoryMulti :: HasNodeStory env err m
-                      => m ([NodeId] -> DBQuery err x NodeListStory)
-getNodeListStoryMulti = do
-  env <- view hasNodeStory
-  pure $ view nse_getter_multi env
 
+getNodeListStoryMulti :: NodeStoryEnv err
+                      -> [NodeId]
+                      -> DBQuery err x NodeListStory
+getNodeListStoryMulti = view nse_getter_multi
 
 
 listNgramsFromRepo :: [ListId]
@@ -102,26 +88,27 @@ listNgramsFromRepo nodeIds ngramsType repo =
 --              Add a static capability parameter would be nice.
 --              Ideally this is the access to `repoVar` which needs to
 --              be properly guarded.
-getListNgrams :: HasNodeStory env err m
-              => [ListId] -> NgramsType
-              -> m (DBQuery err x (HashMap NgramsTerm NgramsRepoElement))
-getListNgrams nodeIds ngramsType = fmap (listNgramsFromRepo nodeIds ngramsType)
-                                 <$> getRepo nodeIds
+getListNgrams :: NodeStoryEnv err
+              -> [ListId]
+              -> NgramsType
+              -> DBQuery err x (HashMap NgramsTerm NgramsRepoElement)
+getListNgrams env nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType
+                                    <$> getRepo env nodeIds
 
 
 -- | Fetch terms from repo, gathering terms under the same root (parent).
-getTermsWith :: forall a env err m x.
-             (HasNodeStory env err m, Eq a, Hashable a)
-          => (NgramsTerm -> a) -> [ListId]
-          -> NgramsType -> Set ListType
-          -> m (DBQuery err x (HashMap a [a]))
-getTermsWith f ls ngt lts  =
+getTermsWith :: forall a err x. Hashable a
+             => NodeStoryEnv err
+             -> (NgramsTerm -> a) -> [ListId]
+             -> NgramsType -> Set ListType
+             -> DBQuery err x (HashMap a [a])
+getTermsWith env f ls ngt lts  =
   let func =    HM.fromListWith (<>)
              .  map toTreeWith
              .  HM.toList
              .  HM.filter (\f' -> Set.member (fst f') lts)
              .  mapTermListRoot ls ngt
-  in fmap func <$> getRepo ls
+  in func <$> getRepo env ls
   where
     toTreeWith :: (NgramsTerm, (b, Maybe NgramsTerm)) -> (a, [a])
     toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of

src/Gargantext/API/Node/Corpus/Export/Utils.hs

@@ -15,6 +15,7 @@ module Gargantext.API.Node.Corpus.Export.Utils
   where
 
 import Control.Exception.Safe qualified as CES
+import Control.Lens (view)
 import Control.Monad.Fail (fail)
 import Data.Aeson qualified as Aeson
 import Data.ByteString.Lazy qualified as BSL
@@ -29,7 +30,7 @@ import Database.SQLite.Simple qualified as S
 import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo)
 import Gargantext.API.Ngrams.Types ( NgramsTerm(..) )
 import Gargantext.API.Node.Corpus.Export.Types (CorpusSQLite(..), CorpusSQLiteData(..))
-import Gargantext.Core.NodeStory.Types ( HasNodeStoryEnv, NodeListStory )
+import Gargantext.Core.NodeStory.Types ( HasNodeStoryEnv (hasNodeStory), NodeListStory )
 import Gargantext.Core.Text.Ngrams (NgramsType(NgramsTerms))
 import Gargantext.Core.Types (CorpusId, ListId, NodeType(NodeList))
 import Gargantext.Core.Types.Main (ListType(..))
@@ -40,12 +41,12 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument)
 import Gargantext.Database.Admin.Types.Hyperdata.List (HyperdataList)
 import Gargantext.Database.Admin.Types.Node (unNodeId, ContextId(..), NodeId(UnsafeMkNodeId))
 import Gargantext.Database.Prelude
-import Gargantext.Database.Schema.Context (context_id, context_name, context_date, context_hyperdata)
-import Gargantext.Database.Schema.Node (node_hash_id, node_hyperdata, node_name, node_parent_id)
 import Gargantext.Database.Query.Table.Node ( defaultList, getNodeWith )
-import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
+import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
+import Gargantext.Database.Schema.Context (context_id, context_name, context_date, context_hyperdata)
+import Gargantext.Database.Schema.Node (node_hash_id, node_hyperdata, node_name, node_parent_id)
 import Gargantext.Prelude
 import Gargantext.System.Logging (logLocM, LogLevel(..), MonadLogger)
 import Paths_gargantext qualified as PG -- cabal magic build module
@@ -85,6 +86,7 @@ mkCorpusSQLiteData :: ( CES.MonadMask m
                    -> Maybe ListId
                    -> m CorpusSQLiteData
 mkCorpusSQLiteData cId lId = do
+  env <- view hasNodeStory
   corpus <- runDBQuery $ getNodeWith cId (Proxy @HyperdataCorpus)
   now <- liftBase getCurrentTime
 
@@ -92,7 +94,7 @@ mkCorpusSQLiteData cId lId = do
         Nothing -> runDBQuery $ defaultList cId
         Just l  -> pure l
 
-  repo <- runDBQuery =<< getRepo [listId]
+  repo <- runDBQuery $ getRepo env [listId]
 
   runDBQuery $ do
     l <- getNodeWith listId (Proxy @HyperdataList)

src/Gargantext/Core/NodeStory.hs

@@ -315,8 +315,8 @@ fromDBNodeStoryEnv pool = do
         --       ) $ Map.toList nls
         -- pure $ clearHistory ns
 
-  pure $ NodeStoryEnv { _nse_saver_immediate = saver_immediate
-                      , _nse_archive_saver_immediate = archive_saver_immediate
+  pure $ NodeStoryEnv { _nse_saver = saver_immediate
+                      , _nse_archive_saver = archive_saver_immediate
                       , _nse_getter = \nId -> withResource pool $ \c ->
                           getNodeStory' c nId
                       , _nse_getter_multi = \nIds -> withResource pool $ \c ->

src/Gargantext/Core/NodeStory/Types.hs

@@ -30,8 +30,8 @@ module Gargantext.Core.NodeStory.Types
   , initNodeStory
   , nse_getter
   , nse_getter_multi
-  , nse_saver_immediate
-  , nse_archive_saver_immediate
+  , nse_saver
+  , nse_archive_saver
   -- , nse_var
   , unNodeStory
   , Archive(..)
@@ -188,22 +188,17 @@ type ArchiveList = Archive NgramsState' NgramsStatePatch'
 
 ------------------------------------------------------------------------
 data NodeStoryEnv err = NodeStoryEnv
-  { _nse_saver_immediate :: !(NodeId -> ArchiveList -> DBUpdate err ())
-  , _nse_archive_saver_immediate :: !(NodeId -> ArchiveList -> DBUpdate err ArchiveList)
+  { _nse_saver :: !(NodeId -> ArchiveList -> DBUpdate err ())
+  , _nse_archive_saver :: !(NodeId -> ArchiveList -> DBUpdate err ArchiveList)
   , _nse_getter :: !(forall x. NodeId -> DBQuery err x ArchiveList)
   , _nse_getter_multi :: !(forall x. [NodeId] -> DBQuery err x 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)
   }
 
-type HasNodeStory env err m = ( IsDBCmd env err m
-                              , MonadReader env m
-                              , MonadError  err m
-                              , HasNodeStoryEnv env err
-                              , HasNodeError err
-                              )
+type HasNodeStory env err m = ( Monad m, HasNodeStoryEnv env err, HasNodeError err)
 
-class (HasNodeStoryImmediateSaver err env)
+class HasNodeStoryImmediateSaver err env
   => HasNodeStoryEnv env err where
     hasNodeStory :: Getter env (NodeStoryEnv err)
 

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

@@ -24,7 +24,7 @@ import Gargantext.Core.Notifications.CentralExchange.Types qualified as CE
 import Gargantext.Core.Types (Name)
 import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (DBCmd, DBCmdExtra, runPGSQuery)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Table.Node (getParentId, getNode, getUserRootPublicNode)
 import Gargantext.Database.Query.Table.NodeNode (isNodeReadOnly, SourceId (..), TargetId(..), publishNode, unpublishNode)
@@ -48,20 +48,20 @@ unOnly :: Only a -> a
 unOnly (Only a) = a
 
 -- | Prefer this, because it notifies parents of the node change
-update :: HasNodeError err => UserId -> Update -> DBCmdExtra err [Int]
+update :: HasNodeError err => UserId -> Update -> DBUpdate err ([Int], [CE.CEMessage])
 update _loggedInUserId (Rename nId newName) = do
   ret <- rename_db_update nId newName
   mpId <- getParentId nId
-  case mpId of
-    Nothing -> pure ()
-    Just pId -> CE.ce_notify $ CE.UpdateTreeFirstLevel pId
-  return ret
+  let msgs = case mpId of
+        Nothing -> mempty
+        Just pId -> [CE.UpdateTreeFirstLevel pId]
+  pure $ (ret, msgs)
 update loggedInUserId (Move sourceId targetId) = do
   mbParentId <- getParentId sourceId
 
   -- if the source and the target are the same, this is identity.
   if sourceId == targetId
-    then pure [ _NodeId sourceId ]
+    then pure ([ _NodeId sourceId ], mempty)
     else do
       isSourceRO <- isNodeReadOnly sourceId
       isTargetRO <- isNodeReadOnly targetId
@@ -94,17 +94,16 @@ update loggedInUserId (Move sourceId targetId) = do
           -- this case is not allowed.
           nodeError (NodeIsReadOnly targetId "Both the source and the target are read-only.")
 
-      for_ mbParentId $ CE.ce_notify . CE.UpdateTreeFirstLevel
-      CE.ce_notify $ CE.UpdateTreeFirstLevel targetId
+      let msgs = catMaybes [CE.UpdateTreeFirstLevel <$> mbParentId, Just (CE.UpdateTreeFirstLevel targetId)]
 
-      pure ids
+      pure (ids, msgs)
 
-publish :: HasNodeError err => UserId -> NodeId -> NodePublishPolicy -> DBCmdExtra err Int
+publish :: HasNodeError err => UserId -> NodeId -> NodePublishPolicy -> DBUpdate err Int
 publish loggedInUserId sourceId policy = do
   targetId <- _node_id <$> getUserRootPublicNode loggedInUserId
   publish_node (SourceId sourceId) (TargetId targetId) policy
 
-publish_node :: HasNodeError err => SourceId -> TargetId -> NodePublishPolicy -> DBCmdExtra err Int
+publish_node :: HasNodeError err => SourceId -> TargetId -> NodePublishPolicy -> DBUpdate err Int
 publish_node (SourceId sourceId) (TargetId targetId) policy = do
   sourceNode <- getNode sourceId
   targetNode <- getNode targetId
@@ -126,15 +125,15 @@ publish_node (SourceId sourceId) (TargetId targetId) policy = do
 
 
 -- Issue #400, for now we support only publishing corpus nodes
-check_publish_source_type_allowed :: HasNodeError err => SourceId -> TargetId -> NodeType -> DBCmdExtra err ()
+check_publish_source_type_allowed :: HasNodeError err => SourceId -> TargetId -> NodeType -> DBTx err r ()
 check_publish_source_type_allowed (SourceId nId) (TargetId tId) = \case
   NodeCorpus   -> pure ()
   NodeCorpusV3 -> pure ()
   _            -> nodeError (MoveError nId tId "At the moment only corpus nodes can be published.")
 
 -- TODO-ACCESS
-rename_db_update :: NodeId -> Name -> DBCmd err [Int]
-rename_db_update nId name = map unOnly <$> runPGSQuery "UPDATE nodes SET name=? where id=? returning id" (DT.take 255 name, nId)
+rename_db_update :: NodeId -> Name -> DBUpdate err [Int]
+rename_db_update nId name = map unOnly <$> mkPGUpdateReturningMany "UPDATE nodes SET name=? where id=? returning id" (DT.take 255 name, nId)
 
-move_db_update :: NodeId -> NodeId -> DBCmd err [Int]
-move_db_update nId pId = map unOnly <$> runPGSQuery "UPDATE nodes SET parent_id= ? where id=? returning id" (pId, nId)
+move_db_update :: NodeId -> NodeId -> DBUpdate err [Int]
+move_db_update nId pId = map unOnly <$> mkPGUpdateReturningMany "UPDATE nodes SET parent_id= ? where id=? returning id" (pId, nId)

src/Gargantext/Database/Transactional/Example.hs

@@ -18,7 +18,6 @@ import Gargantext.Database.Query.Table.NodeNode qualified as GGTX hiding (insert
 import Gargantext.Database.Query.Tree.Root (selectRoot)
 import Gargantext.Database.Schema.Node (_node_id)
 import Gargantext.Database.Schema.Node (node_user_id)
-import Gargantext.Database.Transactional
 import Gargantext.Prelude (panicTrace, headMay)
 import Opaleye
 import Prelude