WIP3

src/Gargantext/API/Ngrams/Tools.hs

@@ -29,6 +29,7 @@ import Gargantext.Core.NodeStory.Types
 import Gargantext.Core.Text.Ngrams (NgramsType)
 import Gargantext.Core.Types.Main ( ListType(..) )
 import Gargantext.Database.Admin.Types.Node ( NodeId, ListId )
+import Gargantext.Database.Prelude
 import Gargantext.Prelude
 
 
@@ -39,10 +40,10 @@ type RootTerm = NgramsTerm
 
 
 getRepo :: HasNodeStory env err m
-         => [ListId] -> m NodeListStory
+         => [ListId] -> m (DBQuery err x NodeListStory)
 getRepo listIds = do
   f <- getNodeListStoryMulti
-  liftBase $ f listIds
+  pure $ f listIds
   -- v  <- liftBase $ f listIds
   -- v' <- liftBase $ atomically $ readTVar v
   -- pure $ v'
@@ -58,24 +59,23 @@ repoSize repo node_id = Map.map Map.size state'
                    . a_state
 
 
-getNodeStory :: HasNodeStory env err m
-           => ListId -> m ArchiveList
+getNodeStory :: HasNodeStory env err m => ListId -> m (DBQuery err x ArchiveList)
 getNodeStory l = do
   f <- getNodeListStory
-  liftBase $ f l
+  pure $ f l
   -- v  <- liftBase $ f l
   -- pure v
 
 
 getNodeListStory :: HasNodeStory env err m
-                 => m (NodeId -> IO ArchiveList)
+                 => m (NodeId -> DBQuery err x ArchiveList)
 getNodeListStory = do
   env <- view hasNodeStory
   pure $ view nse_getter env
 
 
 getNodeListStoryMulti :: HasNodeStory env err m
-                      => m ([NodeId] -> IO NodeListStory)
+                      => m ([NodeId] -> DBQuery err x NodeListStory)
 getNodeListStoryMulti = do
   env <- view hasNodeStory
   pure $ view nse_getter_multi env
@@ -104,23 +104,24 @@ listNgramsFromRepo nodeIds ngramsType repo =
 --              be properly guarded.
 getListNgrams :: HasNodeStory env err m
               => [ListId] -> NgramsType
-              -> m (HashMap NgramsTerm NgramsRepoElement)
-getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType
+              -> m (DBQuery err x (HashMap NgramsTerm NgramsRepoElement))
+getListNgrams nodeIds ngramsType = fmap (listNgramsFromRepo nodeIds ngramsType)
                                  <$> getRepo nodeIds
 
 
 -- | Fetch terms from repo, gathering terms under the same root (parent).
-getTermsWith :: forall a env err m.
+getTermsWith :: forall a env err m x.
              (HasNodeStory env err m, Eq a, Hashable a)
           => (NgramsTerm -> a) -> [ListId]
           -> NgramsType -> Set ListType
-          -> m (HashMap a [a])
-getTermsWith f ls ngt lts  = HM.fromListWith (<>)
-                      <$> map toTreeWith
-                      <$> HM.toList
-                      <$> HM.filter (\f' -> Set.member (fst f') lts)
-                      <$> mapTermListRoot ls ngt
-                      <$> getRepo ls
+          -> m (DBQuery err x (HashMap a [a]))
+getTermsWith 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
   where
     toTreeWith :: (NgramsTerm, (b, Maybe NgramsTerm)) -> (a, [a])
     toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of

src/Gargantext/API/Node/Share.hs

@@ -72,10 +72,21 @@ api userInviting nId (ShareTeamParams user') = do
             pure ()
           pure u
 
-  fromIntegral <$> DB.shareNodeWith (ShareNodeWith_User NodeFolderShared (UserName user)) nId
+  fromIntegral <$> shareNodeAndNotify (ShareNodeWith_User NodeFolderShared (UserName user)) nId
 api _uId nId2 (SharePublicParams nId1) =
 
-  fromIntegral <$> DB.shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId1) nId2
+  fromIntegral <$> shareNodeAndNotify (ShareNodeWith_Node NodeFolderPublic nId1) nId2
+
+shareNodeAndNotify :: ( HasNodeError     err
+                      , IsDBCmdExtra env err m
+                      , MonadRandom          m
+                      )
+                      -> DBUpdate err (Int, [CEMessage])
+                      -> m Int
+shareNodeAndNotify dbTx = do
+  (res, msgs) <- runDbTx dbTx
+  forM_ msgs CE.ce_notify
+  pure res
 
 -- | Unshare a previously shared node via the /share endpoint.
 unShare :: IsGargServer env err m => NodeId -> Named.UnshareNode (AsServerT m)

src/Gargantext/Core/NodeStory/Types.hs

@@ -204,7 +204,7 @@ type HasNodeStory env err m = ( IsDBCmd env err m
                               )
 
 class (HasNodeStoryImmediateSaver err env)
-  => HasNodeStoryEnv err env where
+  => HasNodeStoryEnv env err where
     hasNodeStory :: Getter env (NodeStoryEnv err)
 
 class HasNodeStoryImmediateSaver err env where

src/Gargantext/Database/Action/Delete.hs

@@ -27,7 +27,7 @@ import Gargantext.Database.Action.User (getUserId)
 import Gargantext.Database.Admin.Types.Hyperdata.File ( HyperdataFile(..) )
 import Gargantext.Database.Admin.Types.Node ( NodeId, NodeType(..) ) -- (NodeType(..))
 import Gargantext.Database.GargDB qualified as GargDB
-import Gargantext.Database.Prelude (Cmd, IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getNodeWith)
 import Gargantext.Database.Query.Table.Node qualified as N (getNode, deleteNode)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
@@ -38,16 +38,18 @@ import Gargantext.Prelude
 -- TODO
 -- Delete Corpus children accoring its types
 -- Delete NodeList (NodeStory + cbor file)
-deleteNode :: (IsDBEnvExtra env, HasNodeError err)
+-- FIXME(adinapoli): this function mixes db queries with side effects, we can
+-- probably make it more compositional.
+deleteNode :: (HasNodeError err)
            => User
            -> NodeId
-           -> Cmd env err Int
+           -> DBCmd err Int
 deleteNode u nodeId = do
-  node' <- N.getNode nodeId
+  node' <- runDBQuery $ N.getNode nodeId
   num <- case (view node_typename node') of
     nt | nt == toDBid NodeUser -> panicTrace "[G.D.A.D.deleteNode] Not allowed to delete NodeUser (yet)"
     nt | nt == toDBid NodeTeam -> do
-      uId   <- getUserId u
+      uId   <- runDBQuery $ getUserId u
       if _node_user_id node' == uId
         then N.deleteNode    nodeId
         else delFolderTeam u nodeId

src/Gargantext/Database/Action/Share.hs

@@ -44,7 +44,7 @@ data ShareNodeWith = ShareNodeWith_User !NodeType !User
                    | ShareNodeWith_Node !NodeType !NodeId
 
 ------------------------------------------------------------------------
-deleteMemberShip :: HasNodeError err => [(SharedFolderId, TeamNodeId)] -> DBCmdExtra err [Int]
+deleteMemberShip :: HasNodeError err => [(SharedFolderId, TeamNodeId)] -> DBUpdate err [Int]
 deleteMemberShip xs = mapM (\(s,t) -> deleteNodeNode s t) xs
 
 ------------------------------------------------------------------------
@@ -56,9 +56,9 @@ type TeamNodeId     = NodeId
 -- Result gives the username and its SharedFolderId that has to be eventually
 -- used for the membership
 membersOf :: HasNodeError err
-          => TeamNodeId -> DBCmdExtra err [(Text, SharedFolderId)]
+          => TeamNodeId -> DBQuery err x [(Text, SharedFolderId)]
 membersOf nId = do
-  res <- runOpaQuery $ membersOfQuery nId
+  res <- mkOpaQuery $ membersOfQuery nId
   pure $ catMaybes (uncurryMaybe <$> res)
 
 
@@ -91,7 +91,9 @@ shareNodeWith :: HasNodeError err
               -> NodeId
               -- ^ The target node we would like to share, it has
               -- to be a 'NodeFolderShared'.
-              -> DBCmdExtra err Int
+              -> DBUpdate err (Int, [CE.CEMessage])
+              -- ^ Returns as the second argument the list of messages
+              -- we need to submit to the central exchange.
 shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
   nodeToCheck <- getNode   n
   userIdCheck <- getUserId u
@@ -103,9 +105,8 @@ shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
         else do
           folderSharedId  <- getFolderId u NodeFolderShared
           ret <- shareNode (SourceId folderSharedId) (TargetId n)
-          void $ CE.ce_notify $ CE.UpdateTreeFirstLevel folderSharedId
-          void $ CE.ce_notify $ CE.UpdateTreeFirstLevel n
-          pure ret
+          let msgs = [CE.UpdateTreeFirstLevel folderSharedId, CE.UpdateTreeFirstLevel n]
+          pure (ret, msgs)
 
 shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
   nodeToCheck <- getNode n
@@ -117,15 +118,14 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
       if hasNodeType folderToCheck NodeFolderPublic
         then do
           ret <- shareNode (SourceId nId) (TargetId n)
-          void $ CE.ce_notify $ CE.UpdateTreeFirstLevel nId
-          void $ CE.ce_notify $ CE.UpdateTreeFirstLevel n
-          pure ret
+          let msgs = [CE.UpdateTreeFirstLevel nId, CE.UpdateTreeFirstLevel n]
+          pure (ret, msgs)
         else errorWith "[G.D.A.S.shareNodeWith] Can share NodeWith NodeFolderPublic only"
 
 shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType"
 
 ------------------------------------------------------------------------
-getFolderId :: HasNodeError err => User -> NodeType -> DBCmd err NodeId
+getFolderId :: HasNodeError err => User -> NodeType -> DBQuery err x NodeId
 getFolderId u nt = do
   rootId <- getRootId u
   s <- getNodesWith rootId HyperdataAny (Just nt) Nothing Nothing
@@ -136,12 +136,12 @@ getFolderId u nt = do
 ------------------------------------------------------------------------
 type TeamId = NodeId
 
-delFolderTeam :: HasNodeError err => User -> TeamId -> DBCmdExtra err Int
+delFolderTeam :: HasNodeError err => User -> TeamId -> DBUpdate err Int
 delFolderTeam u nId = do
   folderSharedId <- getFolderId u NodeFolderShared
   deleteNodeNode folderSharedId nId
 
 unshare :: HasNodeError err
         => ParentId -> NodeId
-        -> DBCmdExtra err Int
+        -> DBUpdate err Int
 unshare p n = deleteNodeNode p n