Almost there?

src/Gargantext/API/GraphQL/Context.hs

@@ -33,7 +33,7 @@ import Gargantext.API.Prelude (GargM)
 import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument )
 import Gargantext.Database.Admin.Types.Node (ContextTitle, NodeId(..), NodeTypeId, UserId, unNodeId, ContextId (..))
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.NodeContext (getNodeContext, getContextsForNgramsTerms, ContextForNgramsTerms(..), {- getContextNgrams, -} getContextNgramsMatchingFTS)
 import Gargantext.Database.Query.Table.NodeContext qualified as DNC
 import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..))
@@ -147,7 +147,7 @@ dbNodeContext context_id node_id = do
 --  user <- getUsersWithId user_id
 --  hyperdata <- getUserHyperdata user_id
 --  lift (map toUser <$> zip user hyperdata)
-  c <- lift $ getNodeContext (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id)
+  c <- lift $ runDBQuery $ getNodeContext (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id)
   pure $ toNodeContextGQL <$> [c]
 
 -- | Returns list of `ContextGQL` for given ngrams in given corpus id.
@@ -155,7 +155,7 @@ dbContextForNgrams
   :: (IsDBEnvExtra env)
   => Int -> [Text] -> Text -> GqlM e env [ContextGQL]
 dbContextForNgrams node_id ngrams_terms and_logic = do
-  contextsForNgramsTerms <- lift $ getContextsForNgramsTerms (UnsafeMkNodeId node_id) ngrams_terms ( readMaybe $ unpack $ Text.toTitle and_logic )
+  contextsForNgramsTerms <- lift $ runDBQuery $ getContextsForNgramsTerms (UnsafeMkNodeId node_id) ngrams_terms ( readMaybe $ unpack $ Text.toTitle and_logic )
   --lift $ printDebug "[dbContextForNgrams] contextsForNgramsTerms" contextsForNgramsTerms
   pure $ toContextGQL <$> contextsForNgramsTerms
 
@@ -164,7 +164,7 @@ dbContextNgrams
   :: (IsDBEnvExtra env)
   => Int -> Int -> GqlM e env [Text]
 dbContextNgrams context_id list_id = do
-  lift $ getContextNgramsMatchingFTS (UnsafeMkContextId context_id) (UnsafeMkNodeId list_id)
+  lift $ runDBQuery $ getContextNgramsMatchingFTS (UnsafeMkContextId context_id) (UnsafeMkNodeId list_id)
 
 -- Conversion functions
 
@@ -228,5 +228,5 @@ updateNodeContextCategory :: (IsDBEnvExtra env)
                           -> GqlM' e env [Int]
 updateNodeContextCategory autUser mgr NodeContextCategoryMArgs { context_id, node_id, category } =
   withPolicy autUser mgr (nodeWriteChecks $ UnsafeMkNodeId node_id) $ do
-    void $ lift $ DNC.updateNodeContextCategory (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id) category
+    void $ lift $ runDBTx $ DNC.updateNodeContextCategory (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id) category
     pure [1]

src/Gargantext/API/GraphQL/Node.hs

@@ -24,7 +24,7 @@ import Gargantext.API.GraphQL.Types ( GqlM )
 import Gargantext.Core ( HasDBid(lookupDBid) )
 import Gargantext.Database.Admin.Types.Node (NodeType)
 import Gargantext.Database.Admin.Types.Node qualified as NN
-import Gargantext.Database.Prelude (IsDBEnvExtra)  -- , JSONB)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getClosestChildrenByType, getClosestParentIdByType, getNode)
 import Gargantext.Database.Schema.Node qualified as N
 import Gargantext.Prelude
@@ -74,14 +74,14 @@ dbNodes
   :: (IsDBEnvExtra env)
   => Int -> GqlM e env [Node]
 dbNodes node_id = do
-  node <- lift $ getNode $ NN.UnsafeMkNodeId node_id
+  node <- lift $ runDBQuery $ getNode $ NN.UnsafeMkNodeId node_id
   pure [toNode node]
 
 dbNodesCorpus
   :: (IsDBEnvExtra env)
   => Int -> GqlM e env [Corpus]
 dbNodesCorpus corpus_id = do
-  corpus <- lift $ getNode $ NN.UnsafeMkNodeId corpus_id
+  corpus <- lift $ runDBQuery $ getNode $ NN.UnsafeMkNodeId corpus_id
   pure [toCorpus corpus]
 
 data NodeParentArgs
@@ -116,19 +116,21 @@ dbParentNodes node_id parentType = do
   --     lift $ printDebug "[dbParentNodes] error reading parent type" (T.pack err)
   --     pure []
   --   Right parentType -> do
-      mNodeId <- lift $ getClosestParentIdByType (NN.UnsafeMkNodeId node_id) parentType -- (fromNodeTypeId parent_type_id)
+  lift $ runDBQuery $ do
+      mNodeId <- getClosestParentIdByType (NN.UnsafeMkNodeId node_id) parentType -- (fromNodeTypeId parent_type_id)
       case mNodeId of
         Nothing -> pure []
         Just id -> do
-          node <- lift $ getNode id
+          node <- getNode id
           pure [toNode node]
 
 dbChildNodes :: (IsDBEnvExtra env)
              => Int -> NodeType -> GqlM e env [Node]
 dbChildNodes node_id childType = do
-  childIds <- lift $ getClosestChildrenByType (NN.UnsafeMkNodeId node_id) childType -- (fromNodeTypeId parent_type_id)
-  children <- lift $ mapM getNode childIds
-  pure $ toNode <$> children
+  lift $ runDBQuery $ do
+    childIds <- getClosestChildrenByType (NN.UnsafeMkNodeId node_id) childType -- (fromNodeTypeId parent_type_id)
+    children <- mapM getNode childIds
+    pure $ toNode <$> children
 
 toNode :: NN.Node json -> Node
 toNode N.Node { .. } = Node { id = nid

src/Gargantext/API/GraphQL/Team.hs

@@ -25,7 +25,7 @@ import Gargantext.Core.Config (HasJWTSettings)
 import Gargantext.Core.Types (NodeId(..), unNodeId)
 import Gargantext.Core.Types.Individu qualified as Individu
 import Gargantext.Database.Action.Share (membersOf, deleteMemberShip)
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.User (getUsersWithNodeHyperdata)
 import Gargantext.Database.Schema.Node (NodePoly(Node, _node_id), _node_user_id)
@@ -60,13 +60,14 @@ dbTeam :: (IsDBEnvExtra env) =>
           Int -> GqlM e env Team
 dbTeam nodeId = do
   let nId = UnsafeMkNodeId nodeId
-  res <- lift $ membersOf nId
-  teamNode <- lift $ getNode nId
-  userNodes <- lift $ getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
-  let username = getUsername userNodes
-  pure $ Team { team_owner_username = username
-              , team_members = map toTeamMember res
-              }
+  lift $ runDBQuery $ do
+    res <- membersOf nId
+    teamNode <- getNode nId
+    userNodes <- getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
+    let username = getUsername userNodes
+    pure $ Team { team_owner_username = username
+                , team_members = map toTeamMember res
+                }
   where
     toTeamMember :: (Text, NodeId) -> TeamMember
     toTeamMember (username, fId)= TeamMember {
@@ -81,18 +82,19 @@ dbTeam nodeId = do
 deleteTeamMembership :: (IsDBEnvExtra env, HasJWTSettings env) =>
                         TeamDeleteMArgs -> GqlM' e env [Int]
 deleteTeamMembership TeamDeleteMArgs { token, shared_folder_id, team_node_id } = do
-  teamNode <- lift $ getNode $ UnsafeMkNodeId team_node_id
-  userNodes <- lift (getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode)
+  userNodes <- lift $ runDBTx $ do
+    teamNode <- getNode $ UnsafeMkNodeId team_node_id
+    getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
   case userNodes of
-    [] -> panicTrace $ "[deleteTeamMembership] User with id " <> T.pack (show $ uId teamNode) <> " doesn't exist."
+    [] -> panicTrace $ "[deleteTeamMembership] User with id " <> T.pack (show $ team_node_id) <> " doesn't exist."
     (( _, node_u):_) -> do
       testAuthUser <- lift $ authUser (nId node_u) token
-      lift $ case testAuthUser of
+      case testAuthUser of
         -- Invalid -> panicTrace "[deleteTeamMembership] failed to validate user"
         Invalid -> do
-          throwError $ InternalAuthenticationError $ UserNotAuthorized (uId node_u) "This user is not team owner"
+          lift $ throwError $ InternalAuthenticationError $ UserNotAuthorized (uId node_u) "This user is not team owner"
         Valid -> do
-          deleteMemberShip [(UnsafeMkNodeId shared_folder_id, UnsafeMkNodeId team_node_id)]
+          lift $ runDBTx $ deleteMemberShip [(UnsafeMkNodeId shared_folder_id, UnsafeMkNodeId team_node_id)]
   where
     uId Node { _node_user_id } = _node_user_id
     nId Node { _node_id } = _node_id

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

@@ -25,7 +25,7 @@ import Gargantext.Core.Types.Main ( Tree(..), _tn_node, _tn_children, NodeTree(.
 import Gargantext.Database.Admin.Config ()
 import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId(..), NodeType)
 import Gargantext.Database.Admin.Types.Node qualified as NN
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Tree qualified as T
 import Gargantext.Database.Schema.Node (NodePoly(_node_parent_id))
@@ -77,10 +77,11 @@ dbTree :: (IsDBEnvExtra env) =>
           NN.UserId -> Int -> GqlM e env (TreeFirstLevel (GqlM e env))
 dbTree loggedInUserId root_id = do
   let rId = UnsafeMkNodeId root_id
-  t <- lift $ T.tree loggedInUserId T.TreeFirstLevel rId allNodeTypes
-  n <- lift $ getNode $ UnsafeMkNodeId root_id
-  let pId = toParentId n
-  pure $ toTree rId pId t
+  lift $ runDBQuery $ do
+    t <- T.tree loggedInUserId T.TreeFirstLevel rId allNodeTypes
+    n <- getNode $ UnsafeMkNodeId root_id
+    let pId = toParentId n
+    pure $ toTree rId pId t
   where
     toParentId N.Node { _node_parent_id } = _node_parent_id
 
@@ -100,7 +101,7 @@ childrenToTreeNodes (TreeN {_tn_node}, rId) = toTreeNode (Just rId) _tn_node
 
 resolveParent :: (IsDBEnvExtra env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
 resolveParent (Just pId) = do
-  node <- lift $ getNode pId
+  node <- lift $ runDBQuery $ getNode pId
   pure $ nodeToTreeNode node
 resolveParent Nothing = pure Nothing
 
@@ -133,6 +134,6 @@ convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_par
 dbRecursiveParents :: (IsDBEnvExtra env) => Int -> GqlM e env BreadcrumbInfo
 dbRecursiveParents nodeId = do
   let nId = UnsafeMkNodeId nodeId
-  dbParents <- lift $ T.recursiveParents nId allNodeTypes
+  dbParents <- lift $ runDBQuery $ T.recursiveParents nId allNodeTypes
   let treeNodes = map convertDbTreeToTreeNode dbParents
   pure $ BreadcrumbInfo { parents = treeNodes }

src/Gargantext/API/GraphQL/User.hs

@@ -22,7 +22,7 @@ import Gargantext.API.GraphQL.Types (GqlM, GqlM')
 import Gargantext.Core.Types (NodeId(..), UserId)
 import Gargantext.Core.Types.Individu qualified as Individu
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..))
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.User qualified as DBUser
 import Gargantext.Database.Schema.User (UserLight(..))
 import Gargantext.Prelude
@@ -72,7 +72,7 @@ resolveUsers autUser mgr UserArgs { user_id } = do
 -- | Inner function to fetch the user from DB.
 dbUsers :: (IsDBEnvExtra env)
         => Int -> GqlM e env [User (GqlM e env)]
-dbUsers user_id = lift (map toUser <$> DBUser.getUsersWithId (Individu.RootId $ UnsafeMkNodeId user_id))
+dbUsers user_id = lift (map toUser <$> runDBQuery (DBUser.getUsersWithId (Individu.RootId $ UnsafeMkNodeId user_id)))
 
 toUser
   :: (IsDBEnvExtra env)
@@ -85,25 +85,25 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
 resolveHyperdata
   :: (IsDBEnvExtra env)
   => UserId -> GqlM e env (Maybe HyperdataUser)
-resolveHyperdata userid = lift (listToMaybe <$> DBUser.getUserHyperdata (Individu.UserDBId userid))
+resolveHyperdata userid = lift (listToMaybe <$> runDBQuery (DBUser.getUserHyperdata (Individu.UserDBId userid)))
 
 updateUserPubmedAPIKey :: ( IsDBEnvExtra env ) =>
                           UserPubmedAPIKeyMArgs -> GqlM' e env Int
 updateUserPubmedAPIKey UserPubmedAPIKeyMArgs { user_id, api_key } = do
-  _ <- lift $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ UnsafeMkNodeId user_id) api_key
+  _ <- lift $ runDBTx $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ UnsafeMkNodeId user_id) api_key
 
   pure 1
 
 updateUserEPOAPIUser :: ( IsDBEnvExtra env ) =>
                         UserEPOAPIUserMArgs -> GqlM' e env Int
 updateUserEPOAPIUser UserEPOAPIUserMArgs { user_id, api_user } = do
-  _ <- lift $ DBUser.updateUserEPOAPIUser (Individu.RootId $ UnsafeMkNodeId user_id) api_user
+  _ <- lift $ runDBTx $ DBUser.updateUserEPOAPIUser (Individu.RootId $ UnsafeMkNodeId user_id) api_user
 
   pure 1
 
 updateUserEPOAPIToken :: ( IsDBEnvExtra env ) =>
                          UserEPOAPITokenMArgs -> GqlM' e env Int
 updateUserEPOAPIToken UserEPOAPITokenMArgs { user_id, api_token } = do
-  _ <- lift $ DBUser.updateUserEPOAPIToken (Individu.RootId $ UnsafeMkNodeId user_id) api_token
+  _ <- lift $ runDBTx $ DBUser.updateUserEPOAPIToken (Individu.RootId $ UnsafeMkNodeId user_id) api_token
 
   pure 1

src/Gargantext/API/GraphQL/UserInfo.hs

@@ -49,7 +49,7 @@ import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser)
 import Gargantext.Core.Config (HasJWTSettings)
 import Gargantext.Core.Types (UserId(..))
 import Gargantext.Core.Types.Individu qualified as Individu
-import Gargantext.Database.Prelude (IsDBEnvExtra)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Query.Table.User (getUsersWithHyperdata, getUsersWithNodeHyperdata, updateUserEmail)
 import Gargantext.Database.Schema.Node (node_id, node_hyperdata, NodePoly (Node, _node_id))
@@ -124,7 +124,7 @@ updateUserInfo
   => UserInfoMArgs -> GqlM' e env Int
 updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
   -- lift $ printDebug "[updateUserInfo] ui_id" ui_id
-  users <- lift (getUsersWithNodeHyperdata (Individu.UserDBId $ UnsafeMkUserId ui_id))
+  users <- lift $ runDBQuery $ getUsersWithNodeHyperdata (Individu.UserDBId $ UnsafeMkUserId ui_id)
   case users of
     [] -> panicTrace $ "[updateUserInfo] User with id " <> (T.pack $ show ui_id) <> " doesn't exist."
     ((UserLight { .. }, node_u):_) -> do
@@ -155,10 +155,11 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
           let u' = UserLight { userLight_email = fromMaybe userLight_email $ view ui_cwTouchMailL u_hyperdata'
                              , .. }
           -- lift $ printDebug "[updateUserInfo] with firstName" u_hyperdata'
-          _ <- lift $ updateHyperdata (node_u ^. node_id) u_hyperdata'
-          _ <- lift $ updateUserEmail u'
-          --let _newUser = toUser (u, u_hyperdata')
-          pure 1
+          lift $ runDBTx $ do
+            _ <- updateHyperdata (node_u ^. node_id) u_hyperdata'
+            _ <- updateUserEmail u'
+            --let _newUser = toUser (u, u_hyperdata')
+            pure 1
   where
     uh _ Nothing u_hyperdata = u_hyperdata
     uh lens' (Just val) u_hyperdata = u_hyperdata & lens' ?~ val
@@ -175,7 +176,7 @@ dbUsers user_id = do
 --  user <- getUsersWithId user_id
 --  hyperdata <- getUserHyperdata user_id
 --  lift (map toUser <$> zip user hyperdata)
-  lift (map toUser <$> getUsersWithHyperdata (Individu.UserDBId user_id))
+  lift (map toUser <$> runDBQuery (getUsersWithHyperdata (Individu.UserDBId user_id)))
 
 toUser :: (UserLight, HyperdataUser) -> UserInfo
 toUser (UserLight { .. }, u_hyperdata) =

src/Gargantext/API/Members.hs

@@ -15,6 +15,7 @@ import Gargantext.API.Routes.Named.Private qualified as Named
 import Gargantext.Database.Action.Share (membersOf)
 import Gargantext.Database.Admin.Types.Node (NodeType(NodeTeam))
 import Gargantext.Database.Query.Table.Node (getNodesIdWithType)
+import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Servant.Server.Generic (AsServerT)
 
@@ -22,7 +23,7 @@ members :: IsGargServer err env m => Named.MembersAPI (AsServerT m)
 members = Named.MembersAPI getMembers
 
 getMembers :: IsGargServer err env m => m [Text]
-getMembers = do
+getMembers = runDBQuery $ do
   teamNodeIds <- getNodesIdWithType NodeTeam
   m <- concatMapM membersOf teamNodeIds
   pure $ map fst m

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

@@ -17,6 +17,7 @@ module Gargantext.API.Node.Corpus.Export
   where
 
 import Control.Exception.Safe qualified as CES
+import Control.Lens (view)
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
@@ -27,10 +28,12 @@ import Gargantext.API.Node.Corpus.Export.Types ( Corpus(..), CorpusSQLite(..) )
 import Gargantext.API.Node.Corpus.Export.Utils (getContextNgrams, mkCorpusSQLite, mkCorpusSQLiteData)
 import Gargantext.API.Node.Document.Export.Types qualified as DocumentExport
 import Gargantext.API.Prelude (IsGargServer)
+import Gargantext.Core.NodeStory
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
 import Gargantext.Core.Types.Main ( ListType(MapTerm) )
-import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..) )
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node ( defaultList )
 import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
 import Gargantext.Database.Schema.Context (_context_id)
@@ -56,35 +59,37 @@ getCorpus cId = Named.CorpusExportAPI {
                -> Maybe NgramsType
                -> m (Headers '[Header "Content-Disposition" Text] Corpus)
     get_corpus lId nt' = do
-      let
-        nt = fromMaybe NgramsTerms nt'
+      env <- view hasNodeStory
+      runDBQuery $ do
+        let
+          nt = fromMaybe NgramsTerms nt'
 
-      listId <- case lId of
-        Nothing -> defaultList cId
-        Just l  -> pure l
+        listId <- case lId of
+          Nothing -> defaultList cId
+          Just l  -> pure l
 
-      -- FIXME(adn) Audit the usage of this, we are converting from a node
-      -- to a context id.
-      ns   <- Map.fromList
-           <$> map (\n -> (nodeId2ContextId $ _context_id n, n))
-           <$> selectDocNodes cId
+        -- FIXME(adn) Audit the usage of this, we are converting from a node
+        -- to a context id.
+        ns   <- Map.fromList
+             <$> map (\n -> (nodeId2ContextId $ _context_id n, n))
+             <$> selectDocNodes cId
 
-      repo <- getRepo [listId]
-      ngs  <- getContextNgrams cId listId MapTerm nt repo
-      let  -- uniqId is hash computed already for each document imported in database
-        r = Map.intersectionWith
-            (\a b -> DocumentExport.Document { _d_document = context2node a
-                                             , _d_ngrams = DocumentExport.Ngrams (Set.toList b) (hash b)
-                                             , _d_hash = d_hash a b }
-            ) ns (Map.map (Set.map unNgramsTerm) ngs)
-              where
-                d_hash :: Context HyperdataDocument -> Set Text -> Text
-                d_hash  _a b = hash [ -- fromMaybe "" (_hd_uniqId $ _context_hyperdata a),
-                                    hash b
-                                   ]
-      pure $ addHeader ("attachment; filename=GarganText_corpus-" <> pack (show cId) <> ".json")
-        $ Corpus { _c_corpus = Map.elems r
-                 , _c_hash = hash $ List.map DocumentExport._d_hash $ Map.elems r }
+        repo <- getRepo env [listId]
+        ngs  <- getContextNgrams cId listId MapTerm nt repo
+        let  -- uniqId is hash computed already for each document imported in database
+          r = Map.intersectionWith
+              (\a b -> DocumentExport.Document { _d_document = context2node a
+                                               , _d_ngrams = DocumentExport.Ngrams (Set.toList b) (hash b)
+                                               , _d_hash = d_hash a b }
+              ) ns (Map.map (Set.map unNgramsTerm) ngs)
+                where
+                  d_hash :: Context HyperdataDocument -> Set Text -> Text
+                  d_hash  _a b = hash [ -- fromMaybe "" (_hd_uniqId $ _context_hyperdata a),
+                                      hash b
+                                     ]
+        pure $ addHeader ("attachment; filename=GarganText_corpus-" <> pack (show cId) <> ".json")
+          $ Corpus { _c_corpus = Map.elems r
+                   , _c_hash = hash $ List.map DocumentExport._d_hash $ Map.elems r }
 
 
 getCorpusSQLite :: ( CES.MonadMask m

src/Gargantext/API/Node/Document/Export.hs

@@ -28,6 +28,7 @@ import Gargantext.API.Prelude (IsGargServer)
 import Gargantext.API.Routes.Named.Document qualified as Named
 import Gargantext.Core (toDBid)
 import Gargantext.Database.Admin.Types.Node (DocId, NodeId, NodeType(..))
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Facet (runViewDocuments, Facet(..))
 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType)
 import Gargantext.Database.Query.Table.Node.User ( getNodeUser )
@@ -64,12 +65,13 @@ getDocumentsJSON nodeUserId pId = do
 
 get_document_json :: IsGargServer err env m => NodeId -> DocId -> m DocumentExport
 get_document_json nodeUserId pId = do
-  uId <- view node_user_id <$> getNodeUser nodeUserId
-  mcId <- getClosestParentIdByType pId NodeCorpus
-  let cId = maybe (panicTrace "[G.A.N.D.Export] Node has no parent") identity mcId
-  docs <- runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing
-  pure DocumentExport { _de_documents = mapFacetDoc uId <$> docs
-                      , _de_garg_version = T.pack $ showVersion PG.version }
+  runDBQuery $ do
+    uId <- view node_user_id <$> getNodeUser nodeUserId
+    mcId <- getClosestParentIdByType pId NodeCorpus
+    let cId = maybe (panicTrace "[G.A.N.D.Export] Node has no parent") identity mcId
+    docs <- runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing
+    pure DocumentExport { _de_documents = mapFacetDoc uId <$> docs
+                        , _de_garg_version = T.pack $ showVersion PG.version }
   where
     mapFacetDoc uId (FacetDoc { .. }) =
       Document { _d_document =

src/Gargantext/API/Node/Phylo/Export.hs

@@ -18,6 +18,7 @@ import Gargantext.API.Routes.Named.Viz qualified as Named
 import Gargantext.Core.Viz.Phylo.API.Tools (getPhyloData, phylo2dot, phylo2dot2json)
 import Gargantext.Core.Viz.Phylo.Example (phyloCleopatre)
 import Gargantext.Database.Admin.Types.Node (PhyloId, NodeId)
+import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Servant
 import Servant.Server.Generic (AsServerT)
@@ -37,7 +38,7 @@ getPhyloJson  :: NodeId
               -> PhyloId
               -> GargNoServer (Headers '[Header "Content-Disposition" T.Text] Value)
 getPhyloJson _ pId = do
-  maybePhyloData <- getPhyloData pId
+  maybePhyloData <- runDBQuery $ getPhyloData pId
   let phyloData = fromMaybe phyloCleopatre maybePhyloData
   phyloJson <- liftBase $ phylo2dot2json phyloData
   pure $ addHeader (T.concat [ "attachment; filename="
@@ -51,7 +52,7 @@ getPhyloDot :: NodeId
             -> PhyloId
             -> GargNoServer (Headers '[Header "Content-Disposition" T.Text] T.Text)
 getPhyloDot _ pId = do
-  maybePhyloData <- getPhyloData pId
+  maybePhyloData <- runDBQuery $ getPhyloData pId
   let phyloData = fromMaybe phyloCleopatre maybePhyloData
   phyloDot <- liftBase $ phylo2dot phyloData
   pure $ addHeader (T.concat [ "attachment; filename="

src/Gargantext/API/Search.hs

@@ -28,6 +28,7 @@ import Gargantext.Core.Types.Search (toRow)
 import Gargantext.Database.Action.Flow.Pairing (isPairedWith)
 import Gargantext.Database.Action.Search (searchInCorpus, searchInCorpusWithContacts)
 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType(..))
+import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Gargantext.System.Logging (logLocM, LogLevel(..))
 import Servant.Server.Generic (AsServerT)
@@ -44,10 +45,10 @@ api nId = Named.SearchAPI $ \query o l order -> case query of
       $(logLocM) DEBUG $ T.pack "New search started with query = " <> (getRawQuery rawQuery)
       SearchResult <$> SearchResultDoc
                    <$> map (toRow nId)
-                   <$> searchInCorpus nId False q o l order
+                   <$> runDBQuery (searchInCorpus nId False q o l order)
   (SearchQuery rawQuery SearchContact) -> case parseQuery rawQuery of
     Left  err -> pure $ SearchResult $ SearchNoResult (T.pack err)
-    Right q   -> do
+    Right q   -> runDBQuery $ do
       -- printDebug "isPairedWith" nId
       aIds <- isPairedWith nId NodeAnnuaire
       -- TODO if paired with several corpus

src/Gargantext/API/Table.hs

@@ -41,7 +41,7 @@ import Gargantext.Core.Types.Query (Offset, Limit)
 import Gargantext.Database.Action.Learn (FavOrTrash(..), moreLike)
 import Gargantext.Database.Action.Search (searchCountInCorpus, searchInCorpus)
 import Gargantext.Database.Admin.Types.Node (ContactId, CorpusId, NodeId)
-import Gargantext.Database.Prelude (IsDBCmdExtra, IsDBCmd, DBCmd)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Facet (FacetDoc , runViewDocuments, runCountDocuments, OrderBy(..), runViewAuthorsDoc)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Prelude
@@ -81,7 +81,7 @@ getTableApi cId tabType mLimit mOffset mOrderBy mQuery mYear =
   where
     get_table = do
       $(logLocM) DEBUG $ "getTable cId = " <> T.pack (show cId)
-      t <- getTable cId tabType mOffset mLimit mOrderBy mQuery mYear
+      t <- runDBQuery $ getTable cId tabType mOffset mLimit mOrderBy mQuery mYear
       pure $ constructHashedResponse t
 
 postTableApi :: (IsDBCmdExtra env err m, MonadLogger m, HasNodeError err)
@@ -91,7 +91,7 @@ postTableApi :: (IsDBCmdExtra env err m, MonadLogger m, HasNodeError err)
 postTableApi cId tq = case tq of
  TableQuery o l order ft "" -> do
    $(logLocM) DEBUG $ "New search with no query"
-   getTable cId (Just ft) (Just o) (Just l) (Just order) Nothing Nothing
+   runDBQuery $ getTable cId (Just ft) (Just o) (Just l) (Just order) Nothing Nothing
  TableQuery o l order ft q  -> case ft of
    Docs  -> do
      $(logLocM) DEBUG $ "New search with query " <> getRawQuery q
@@ -121,7 +121,7 @@ searchInCorpus' cId t q o l order = do
     Left noParseErr -> do
       $(logLocM) ERROR $ "Invalid input query " <> (getRawQuery q) <> " , error = " <> (T.pack noParseErr)
       pure $ TableResult 0 []
-    Right boolQuery -> do
+    Right boolQuery -> runDBQuery $ do
       docs          <- searchInCorpus cId t boolQuery o l order
       countAllDocs  <- searchCountInCorpus cId t (Just boolQuery)
       pure $ TableResult { tr_docs = docs
@@ -136,7 +136,7 @@ getTable :: HasNodeError err
          -> Maybe OrderBy
          -> Maybe RawQuery
          -> Maybe Text
-         -> DBCmd err FacetTableResult
+         -> DBQuery err x FacetTableResult
 getTable cId ft o l order raw_query year = do
   docs      <- getTable' cId ft o l order query year
   docsCount <- runCountDocuments cId (ft == Just Trash) query year
@@ -152,7 +152,7 @@ getTable' :: HasNodeError err
           -> Maybe OrderBy
           -> Maybe Text
           -> Maybe Text
-          -> DBCmd err [FacetDoc]
+          -> DBQuery err x [FacetDoc]
 getTable' cId ft o l order query year =
   case ft of
     (Just Docs)      -> runViewDocuments cId False o l order query year
@@ -164,7 +164,7 @@ getTable' cId ft o l order query year =
 
 getPair :: ContactId -> Maybe TabType
          -> Maybe Offset  -> Maybe Limit
-         -> Maybe OrderBy -> DBCmd err [FacetDoc]
+         -> Maybe OrderBy -> DBQuery err x [FacetDoc]
 getPair cId ft o l order =
   case ft of
     (Just Docs)  -> runViewAuthorsDoc cId False o l order

src/Gargantext/Core/Viz/Chart.hs

@@ -28,7 +28,7 @@ import Gargantext.Database.Admin.Types.Node ( NodeType(NodeList), CorpusId, cont
 import Gargantext.Core.Viz.Types ( Histo(Histo) )
 import Gargantext.Database.Action.Metrics.NgramsByContext ( countContextsByNgramsWith, getContextsByNgramsOnlyUser )
 import Gargantext.Database.Admin.Config ( userMaster )
-import Gargantext.Database.Prelude (DBCmd, DBQuery, runDBQuery)
+import Gargantext.Database.Prelude (DBQuery)
 import Gargantext.Database.Query.Table.Node ( getListsWithParentId )
 import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername )
 import Gargantext.Database.Query.Table.NodeContext (selectDocsDates)
@@ -36,9 +36,9 @@ import Gargantext.Database.Schema.Node ( NodePoly(_node_id) )
 import Gargantext.Prelude hiding (toList)
 
 
-histoData :: CorpusId -> DBCmd err Histo
+histoData :: CorpusId -> DBQuery err x Histo
 histoData cId = do
-  dates <- runDBQuery $ selectDocsDates cId
+  dates <- selectDocsDates cId
   let (ls, css) = V.unzip
                 $ V.fromList
                 $ sortOn fst -- TODO Vector.sortOn

src/Gargantext/Core/Viz/Phylo/API.hs

@@ -28,6 +28,7 @@ import Gargantext.Core.Types.Phylo (GraphData(..))
 import Gargantext.Core.Viz.LegacyPhylo hiding (Phylo(..))
 import Gargantext.Core.Viz.Phylo (PhyloConfig(..), defaultConfig, _phylo_param, _phyloParam_config)
 import Gargantext.Core.Viz.Phylo.API.Tools
+import Gargantext.Database.Prelude
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, defaultList)
@@ -50,12 +51,13 @@ phyloAPI n = Named.PhyloAPI
 -- Add real text processing
 -- Fix Filter parameters
 -- TODO fix parameters to default config that should be in Node
+-- NOTE(adn) this is not DB-tx safe in regards to reads.
 getPhylo :: IsGargServer err env m => PhyloId -> Named.GetPhylo (AsServerT m)
 getPhylo phyloId = Named.GetPhylo $ \lId _level _minSizeBranch -> do
   corpusId <- maybe (nodeLookupError $ NodeParentDoesNotExist phyloId) pure
-              =<< getClosestParentIdByType phyloId NodeCorpus
+              =<< (runDBQuery $ getClosestParentIdByType phyloId NodeCorpus)
   listId   <- case lId of
-                Nothing -> defaultList corpusId
+                Nothing -> runDBQuery $ defaultList corpusId
                 Just ld -> pure ld
   pd <- getPhyloDataJson phyloId
   -- printDebug "getPhylo" theData
@@ -68,7 +70,7 @@ getPhylo phyloId = Named.GetPhylo $ \lId _level _minSizeBranch -> do
 
 getPhyloDataJson :: PhyloId -> GargNoServer (Maybe (GraphData, PhyloConfig))
 getPhyloDataJson phyloId = do
-  phyloData <- getPhyloData phyloId
+  phyloData <- runDBQuery $ getPhyloData phyloId
   phyloJson <- liftBase $ maybePhylo2dot2json phyloData
   case phyloJson of
     Nothing -> pure Nothing
@@ -92,6 +94,8 @@ getPhyloDataJson phyloId = do
   -- pure (SVG p)
 
 
+-- FIXME(adn) This handler mixes DB reads with updates outside of the same
+-- transaction, due to the call to 'flowPhyloAPI' in the middle.
 postPhylo :: IsGargServer err env m => PhyloId -> Named.PostPhylo (AsServerT m)
 postPhylo phyloId = Named.PostPhylo $ \_lId -> do
   -- TODO get Reader settings
@@ -100,12 +104,12 @@ postPhylo phyloId = Named.PostPhylo $ \_lId -> do
     -- _vrs = Just ("1" :: Text)
     -- _sft = Just (Software "Gargantext" "4")
     -- _prm = initPhyloParam vrs sft (Just q)
-  corpusId <- getClosestParentIdByType phyloId NodeCorpus
+  corpusId <- runDBQuery $ getClosestParentIdByType phyloId NodeCorpus
   -- Being the first time we ask for the Phylo, there is no historical data
   -- available about computing time, so we pass 'Nothing'.
   phy <- flowPhyloAPI defaultConfig Nothing (fromMaybe (panicTrace "[G.C.V.P.API] no corpus ID found") corpusId) -- params
   -- phyloId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just corpusId) userId]
-  _ <- updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
+  _ <- runDBTx $ updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
   pure phyloId
 
 ------------------------------------------------------------------------

src/Gargantext/Database/Action/Learn.hs

@@ -34,21 +34,21 @@ data FavOrTrash = IsFav | IsTrash
 
 moreLike :: (HasDBid NodeType, HasNodeError err)
          => CorpusId   -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
-         -> FavOrTrash -> DBCmd err [FacetDoc]
+         -> FavOrTrash -> DBQuery err x [FacetDoc]
 moreLike cId o _l order ft = do
   priors <- getPriors ft cId
   moreLikeWith cId o (Just 3) order ft priors
 
 ---------------------------------------------------------------------------
 getPriors :: (HasDBid NodeType, HasNodeError err)
-          => FavOrTrash -> CorpusId -> DBCmd err (Events Bool)
+          => FavOrTrash -> CorpusId -> DBQuery err x (Events Bool)
 getPriors ft cId = do
 
   docs_fav   <- filter (\(FacetDoc _ _ _ _ f _ _) -> f == Just 2)
-              <$> runDBQuery (runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing)
+              <$> runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing
 
   docs_trash <- List.take (List.length docs_fav)
-            <$> runDBQuery (runViewDocuments cId True Nothing Nothing Nothing Nothing Nothing)
+            <$> runViewDocuments cId True Nothing Nothing Nothing Nothing Nothing
 
 
   let priors = priorEventsWith text (fav2bool ft) (  List.zip (repeat False) docs_fav
@@ -59,11 +59,11 @@ getPriors ft cId = do
 
 moreLikeWith :: (HasDBid NodeType, HasNodeError err)
              => CorpusId   -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
-             -> FavOrTrash -> Events Bool  -> DBCmd err [FacetDoc]
+             -> FavOrTrash -> Events Bool  -> DBQuery err x [FacetDoc]
 moreLikeWith cId o l order ft priors = do
 
   docs_test  <- filter (\(FacetDoc _ _ _ _ f _ _) -> f == Just 1)
-            <$> runDBQuery (runViewDocuments cId False o Nothing order Nothing Nothing)
+            <$> runViewDocuments cId False o Nothing order Nothing Nothing
 
   let results = map fst
        $ filter ((==) (Just $ not $ fav2bool ft) . snd)