Database.Query.Tree refactoring

This commit refactors a bit the internal of the
`Gargantext.Database.Query.Tree` module so that it removes a lot of
repetitive boilerplate and paves the way to more interesting features.

It also:

* Adds the `isUserNode` boolean query
* Adjust source and target in publishNode and unpublishNode
* Pass the currently-logged-in user to tree API functions

src/Gargantext/API/Auth/PolicyCheck.hs

@@ -195,7 +195,8 @@ nodeChecks nid =
   nodeUser nid  `BOr`
   nodeSuper nid `BOr`
   nodeDescendant nid `BOr`
-  nodeShared nid
+  nodeShared nid `BOr`
+  nodePublished nid
 
 -- | A user can move a node from source to target only
 -- if:

src/Gargantext/API/GraphQL/TreeFirstLevel.hs

@@ -15,7 +15,7 @@ Portability : POSIX
 module Gargantext.API.GraphQL.TreeFirstLevel where
 
 import Data.Morpheus.Types (GQLType)
-import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser )
+import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(..) )
 import Gargantext.API.Auth.PolicyCheck (AccessPolicyManager, nodeChecks)
 import Gargantext.API.GraphQL.PolicyCheck (withPolicy)
 import Gargantext.API.GraphQL.Types ( GqlM )
@@ -71,13 +71,13 @@ resolveTree :: (CmdCommon env)
             -> TreeArgs
             -> GqlM e env (TreeFirstLevel (GqlM e env))
 resolveTree autUser mgr TreeArgs { root_id } =
-  withPolicy autUser mgr (nodeChecks $ UnsafeMkNodeId root_id) $ dbTree root_id
+  withPolicy autUser mgr (nodeChecks $ UnsafeMkNodeId root_id) $ dbTree (_auth_user_id autUser) root_id
 
 dbTree :: (CmdCommon env) =>
-          Int -> GqlM e env (TreeFirstLevel (GqlM e env))
-dbTree root_id = do
+          NN.UserId -> Int -> GqlM e env (TreeFirstLevel (GqlM e env))
+dbTree loggedInUserId root_id = do
   let rId = UnsafeMkNodeId root_id
-  t <- lift $ T.tree T.TreeFirstLevel rId allNodeTypes
+  t <- lift $ T.tree loggedInUserId T.TreeFirstLevel rId allNodeTypes
   n <- lift $ getNode $ UnsafeMkNodeId root_id
   let pId = toParentId n
   pure $ toTree rId pId t

src/Gargantext/API/Node.hs

@@ -167,8 +167,8 @@ treeAPI :: IsGargServer env BackendInternalError m
         -> Named.NodeTreeAPI (AsServerT m)
 treeAPI authenticatedUser nodeId mgr =
   withNamedPolicyT authenticatedUser (nodeChecks nodeId) (Named.NodeTreeAPI
-    { nodeTreeEp   = tree TreeAdvanced nodeId
-    , firstLevelEp = tree TreeFirstLevel nodeId
+    { nodeTreeEp   = tree (_auth_user_id authenticatedUser) TreeAdvanced nodeId
+    , firstLevelEp = tree (_auth_user_id authenticatedUser) TreeFirstLevel nodeId
     }) mgr
 
 treeFlatAPI :: IsGargServer env err m
@@ -177,7 +177,7 @@ treeFlatAPI :: IsGargServer env err m
             -> Named.TreeFlatAPI (AsServerT m)
 treeFlatAPI authenticatedUser rootId =
   withNamedAccess authenticatedUser (PathNode rootId) $
-    Named.TreeFlatAPI { getNodesEp = tree_flat rootId }
+    Named.TreeFlatAPI { getNodesEp = tree_flat (_auth_user_id authenticatedUser) rootId }
 
 ------------------------------------------------------------------------
 -- | TODO Check if the name is less than 255 char

src/Gargantext/Core/Text/List/Social/Find.hs

@@ -23,14 +23,17 @@ import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Tree
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Prelude
+import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Schema.Node
 
 ------------------------------------------------------------------------
 findListsId :: (HasNodeError err, HasTreeError err)
             => User -> NodeMode -> DBCmd err [NodeId]
 findListsId u mode = do
   rootId <- getRootId u
+  userNode <- getNode rootId
   ns <- map (view dt_nodeId) <$> filter ((== toDBid NodeList) . (view dt_typeId))
-                             <$> findNodes' rootId mode
+                             <$> findNodes' (_node_user_id userNode) rootId mode
   pure ns
 
 
@@ -39,17 +42,19 @@ findListsId u mode = do
 -- | Shared is for Shared with me but I am not the owner of it
 -- | Private is for all Lists I have created
 findNodes' :: (HasTreeError err, HasNodeError err)
-          => RootId
+          => UserId
+          -> RootId
           -> NodeMode
           -> DBCmd err [DbTreeNode]
-findNodes' r Private = do
-  pv <- (findNodes r Private $ [NodeFolderPrivate]          <> commonNodes)
-  sh <- (findNodes' r Shared)
+findNodes' loggedInUserId r Private = do
+  pv <- (findNodes loggedInUserId r Private $ [NodeFolderPrivate]          <> commonNodes)
+  sh <- (findNodes' loggedInUserId r Shared)
   pure $ pv <> sh
-findNodes' r Shared       = findNodes r Shared  $ [NodeFolderShared, NodeTeam] <> commonNodes
-findNodes' r SharedDirect = findNodes r Shared  $ [NodeFolderShared, NodeTeam] <> commonNodes
-findNodes' r Public       = findNodes r Public  $ [NodeFolderPublic ]          <> commonNodes
-findNodes' r PublicDirect = findNodes r Public  $ [NodeFolderPublic ]          <> commonNodes
+findNodes' loggedInUserId r Shared       = findNodes loggedInUserId r Shared  $ [NodeFolderShared, NodeTeam] <> commonNodes
+findNodes' loggedInUserId r SharedDirect = findNodes loggedInUserId r Shared  $ [NodeFolderShared, NodeTeam] <> commonNodes
+findNodes' loggedInUserId r Public       = findNodes loggedInUserId r Public  $ [NodeFolderPublic ]          <> commonNodes
+findNodes' loggedInUserId r PublicDirect = findNodes loggedInUserId r Public  $ [NodeFolderPublic ]          <> commonNodes
+findNodes' _loggedInUserId _ Published    = pure [] -- FIXME(adn) What's the right behaviour here?
 
 commonNodes:: [NodeType]
 commonNodes = [NodeFolder, NodeCorpus, NodeList, NodeFolderShared, NodeTeam]

src/Gargantext/Core/Types/Main.hs

@@ -38,6 +38,9 @@ data NodeTree = NodeTree { _nt_name      :: Text
                          , _nt_id        :: NodeId
                          } deriving (Show, Read, Generic)
 
+instance Eq NodeTree where
+  (==) d1 d2 = _nt_id d1 == _nt_id d2
+
 $(deriveJSON (unPrefix "_nt_") ''NodeTree)
 instance ToSchema NodeTree where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nt_")

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

@@ -36,6 +36,9 @@ module Gargantext.Database.Query.Table.Node
   , getUserRootPrivateNode
   , selectNode
 
+  -- * Boolean queries
+  , isUserNode
+
   -- * Queries that returns multiple nodes
   , getChildrenByType
   , getClosestChildrenByType
@@ -440,3 +443,14 @@ get_user_root_node_folder nty userId = do
     []      -> nodeError $ NodeLookupFailed $ UserFolderDoesNotExist userId
     [n]     -> pure n
     folders -> nodeError $ NodeLookupFailed $ UserHasTooManyRoots userId (map _node_id folders)
+
+-- | An input 'NodeId' identifies a user node if its typename is 'NodeUser' and it has no parent_id.
+isUserNode :: HasDBid NodeType => NodeId -> DBCmd err Bool
+isUserNode userNodeId = (== [PGS.Only True])
+  <$> runPGSQuery [sql|
+    SELECT EXISTS (
+        SELECT 1
+        FROM nodes
+        WHERE n.id = ? AND n.typename = ? AND n.parent_id = NULL
+    )
+|] (userNodeId, toDBid NodeUser)

src/Gargantext/Database/Query/Table/NodeNode.hs

@@ -23,6 +23,7 @@ module Gargantext.Database.Query.Table.NodeNode
   -- * Types
   , SourceId(..)
   , TargetId(..)
+  , OwnerId(..)
 
   -- * Queries
   , getNodeNode
@@ -258,14 +259,16 @@ selectPublicNodes :: HasDBid NodeType => (Hyperdata a, DefaultFromField SqlJsonb
                   => DBCmd err [(Node a, Maybe Int)]
 selectPublicNodes = runOpaQuery (queryWithType NodeFolderPublic)
 
-publishedNodeIds :: DBCmd err [NodeId]
-publishedNodeIds = map (_nn_node1_id) <$> do_query
+publishedNodeIds :: DBCmd err [(SourceId, TargetId, OwnerId)]
+publishedNodeIds = map (\(owner, nn) -> (SourceId $ _nn_node2_id nn, TargetId $ _nn_node1_id nn, OwnerId owner)) <$> do_query
   where
-    do_query :: DBCmd err [NodeNode]
+    do_query :: DBCmd err [(NodeId, NodeNode)]
     do_query = runOpaQuery $ do
-      n <- queryNodeNodeTable
-      where_ $ (n ^. nn_category .== sqlInt4 (toDBid NNC_read_only_publish))
-      pure n
+      n  <- queryNodeTable
+      nn <- queryNodeNodeTable
+      where_ $ (nn ^. nn_category .== sqlInt4 (toDBid NNC_read_only_publish))
+      where_ $ (n ^. node_id .== nn ^. nn_node1_id)
+      pure (n ^. node_parent_id, nn)
 
 -- | A 'Node' is read-only if there exist a match in the node_nodes directory
 -- where the source is a public folder. Certain category of nodes (like private/shared folders, etc)
@@ -349,23 +352,35 @@ node_NodeNode = proc () -> do
   returnA -< (n, view nn_node2_id <$> nn)
 
 newtype SourceId = SourceId NodeId
+  deriving (Show, Eq, Ord)
 newtype TargetId = TargetId NodeId
+  deriving (Show, Eq, Ord)
+newtype OwnerId = OwnerId NodeId
+  deriving (Show, Eq, Ord)
 
 shareNode :: SourceId -> TargetId -> DBCmd err Int
 shareNode (SourceId sourceId) (TargetId targetId) =
   insertNodeNode [ NodeNode sourceId targetId Nothing Nothing ]
 
 -- | Publishes a node, i.e. it creates a relationship between
--- the input node and the target public folder. It fails if
--- the 'TargetId' doesn't refer to a 'NodeFolderPublic'. Use
--- 'getUserRootPublicNode' to acquire the 'TargetId'.
+-- the input node and the target public folder.
+-- /NOTE/: Even though the semantic of the relationships it
+-- source -> target, by historical reason we store this in the
+-- node_node table backwards, i.e. the public folder first as
+-- the 'node1_id', and the shared node as the target, so we
+-- honour this.
 publishNode :: SourceId -> TargetId -> DBCmd err ()
 publishNode (SourceId sourceId) (TargetId targetId) =
-  void $ insertNodeNode [ NodeNode sourceId targetId Nothing (Just NNC_read_only_publish) ]
+  void $ insertNodeNode [ NodeNode targetId sourceId Nothing (Just NNC_read_only_publish) ]
 
+-- /NOTE/: Even though the semantic of the relationships it
+-- source -> target, by historical reason we store this in the
+-- node_node table backwards, i.e. the public folder first as
+-- the 'node1_id', and the shared node as the target, so we
+-- honour this.
 unpublishNode :: SourceId -> TargetId -> DBCmd err ()
 unpublishNode (SourceId sourceId) (TargetId targetId) =
-  void $ deleteNodeNode sourceId targetId
+  void $ deleteNodeNode targetId sourceId
 
 -- | Pair two nodes together. Typically used to pair
 -- together

src/Gargantext/Database/Query/Tree.hs

@@ -14,6 +14,7 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
 -- see Action/Delete.hs
 -}
 
+{-# LANGUAGE BangPatterns      #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TemplateHaskell   #-}
 
@@ -43,27 +44,27 @@ module Gargantext.Database.Query.Tree
   )
   where
 
-import Control.Lens (view, toListOf, at, each, _Just, to, set)
-import Data.List (tail, nub)
+import Control.Lens qualified as L
+import Control.Lens (view, toListOf, at, each, _Just, to, set, over)
+import Database.PostgreSQL.Simple ( Only(Only), In(In) )
+import Database.PostgreSQL.Simple.SqlQQ ( sql )
+import Data.List.NonEmpty qualified as NE
 import Data.List qualified as List
+import Data.List (tail, nub)
 import Data.Map.Strict (fromListWith, lookup)
 import Data.Text qualified as Text
-import Database.PostgreSQL.Simple ( Only(Only), In(In) )
-import Database.PostgreSQL.Simple.SqlQQ ( sql )
 import Gargantext.Core ( fromDBid, HasDBid(toDBid) )
 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
 import Gargantext.Database.Admin.Config ()
-import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (runPGSQuery, DBCmd)
-import Gargantext.Database.Query.Table.Node (getNodeWith)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
-import Gargantext.Database.Query.Table.NodeNode (getNodeNode)
+import Gargantext.Database.Query.Table.Node (getNode)
+import Gargantext.Database.Query.Table.NodeNode (getNodeNode, publishedNodeIds, SourceId (..), TargetId (..), OwnerId(..))
 import Gargantext.Database.Query.Tree.Error
-import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Database.Schema.NodeNode (NodeNodePoly(..))
+import Gargantext.Database.Schema.Node
 import Gargantext.Prelude hiding (to)
-import qualified Data.List.NonEmpty as NE
 
 ------------------------------------------------------------------------
 data DbTreeNode = DbTreeNode { _dt_nodeId   :: NodeId
@@ -83,13 +84,14 @@ data TreeMode = TreeBasic | TreeAdvanced | TreeFirstLevel
 
 -- | Returns the Tree of Nodes in Database
 tree :: (HasTreeError err, HasNodeError err)
-     => TreeMode
+     => UserId
+     -> TreeMode
      -> RootId
      -> [NodeType]
      -> DBCmd err (Tree NodeTree)
-tree TreeBasic    = tree_basic
-tree TreeAdvanced = tree_advanced
-tree TreeFirstLevel = tree_first_level
+tree _ TreeBasic                   = tree_basic
+tree loggedInUserId TreeAdvanced   = tree_advanced loggedInUserId
+tree loggedInUserId TreeFirstLevel = tree_first_level loggedInUserId
 
 -- | Tree basic returns the Tree of Nodes in Database
 -- (without shared folders)
@@ -98,80 +100,124 @@ tree_basic :: (HasTreeError err, HasNodeError err)
            => RootId
            -> [NodeType]
            -> DBCmd err (Tree NodeTree)
-tree_basic r nodeTypes =
-  (dbTree r nodeTypes <&> toTreeParent) >>= toTree
-  -- Same as (but easier to read) :
-  -- toTree =<< (toTreeParent <$> dbTree r nodeTypes)
+tree_basic r nodeTypes = do
+  trees <- toTree . toTreeParent . map db_tree_to_node_tree <$> dbTree r nodeTypes
+  either treeError pure trees
 
 -- | Advanced mode of the Tree enables shared nodes
 tree_advanced :: (HasTreeError err, HasNodeError err)
-              => RootId
+              => UserId
+              -> RootId
               -> [NodeType]
               -> DBCmd err (Tree NodeTree)
-tree_advanced r nodeTypes = do
-  -- let rPrefix s = "[tree_advanced] root = " <> show r <> " " <> s
-  mainRoot    <- findNodes r Private nodeTypes
-  -- printDebug (rPrefix "mainRoot") mainRoot
-  publicRoots <- findNodes r Public  nodeTypes
-  -- printDebug (rPrefix "publicRoots") publicRoots
-  sharedRoots <- findNodes r Shared  nodeTypes
-  -- printDebug (rPrefix "sharedRoots") sharedRoots
-  -- let ret = toSubtreeParent r (mainRoot <> sharedRoots <> publicRoots)
-  -- printDebug (rPrefix "treeParent") ret
-  -- toTree ret
-  toTree $ toSubtreeParent r (mainRoot <> sharedRoots <> publicRoots)
+tree_advanced loggedInUserId r types = do
+  trees <- tree_find_modes loggedInUserId [ Private, Public, Shared, Published ] r types
+  either treeError pure (toTree . toSubtreeParent r $ trees)
 
 -- | Fetch only first level of tree
 tree_first_level :: (HasTreeError err, HasNodeError err)
-                 => RootId
+                 => UserId
+                 -> RootId
                  -> [NodeType]
                  -> DBCmd err (Tree NodeTree)
-tree_first_level r nodeTypes = do
-  -- let rPrefix s = mconcat [ "[tree_first_level] root = "
-  --                         , show r
-  --                         , ", nodeTypes = "
-  --                         , show nodeTypes
-  --                         , " "
-  --                         , s ]
-  mainRoot    <- findNodes r Private nodeTypes
-  -- printDebug (rPrefix "mainRoot") mainRoot
-  publicRoots <- findNodes r PublicDirect  nodeTypes
-  -- printDebug (rPrefix "publicRoots") publicRoots
-  sharedRoots <- findNodes r SharedDirect  nodeTypes
-  -- printDebug (rPrefix "sharedRoots") sharedRoots
-  ret <- toTree $ toSubtreeParent r (mainRoot <> sharedRoots <> publicRoots)
-  -- printDebug (rPrefix "tree") ret
-  pure ret
+tree_first_level loggedInUserId r types = do
+  trees <- tree_find_modes loggedInUserId [ Private, PublicDirect, SharedDirect ] r types
+  either treeError pure (toTree . toSubtreeParent r $ trees)
 
 -- | Fetch tree in a flattened form
 tree_flat :: (HasTreeError err, HasNodeError err)
-          => RootId
+          => UserId
+          -> RootId
           -> [NodeType]
           -> Maybe Text
           -> DBCmd err [NodeTree]
-tree_flat r nodeTypes q = do
-  mainRoot <- findNodes r Private nodeTypes
-  publicRoots <- findNodes r Public nodeTypes
-  sharedRoots <- findNodes r Shared nodeTypes
-  let ret = map toNodeTree (mainRoot <> sharedRoots <> publicRoots)
-  case q of
-    Just v -> pure $ filter (\(NodeTree {_nt_name}) -> Text.isInfixOf (Text.toLower v) (Text.toLower _nt_name)) ret
-    Nothing -> pure $ ret
-
+tree_flat loggedInUserId r nodeTypes q = do
+  trees <- map snd <$> tree_find_modes loggedInUserId [Private, Public, Shared] r nodeTypes
+  pure $ case q of
+    Just v  -> filter (\(NodeTree {_nt_name}) -> Text.isInfixOf (Text.toLower v) (Text.toLower _nt_name)) trees
+    Nothing -> trees
+
+-- | Collect all the subtrees given for the input 'NodeMode' list.
+tree_find_modes :: (HasTreeError err, HasNodeError err)
+                => UserId
+                -> [NodeMode]
+                -> RootId
+                -> [NodeType]
+                -> DBCmd err [(Maybe ParentId, NodeTree)]
+tree_find_modes loggedInUserId nodeModes r nodeTypes = do
+  foldM (\ !acc mode -> findNodes loggedInUserId r mode nodeTypes <&> \dbTrees -> acc <> map db_tree_to_node_tree dbTrees) [] nodeModes
+
+db_tree_to_node_tree :: DbTreeNode -> (Maybe ParentId, NodeTree)
+db_tree_to_node_tree t = (_dt_parentId t, toNodeTree t)
 
 ------------------------------------------------------------------------
-data NodeMode = Private | Shared | Public | SharedDirect | PublicDirect
+data NodeMode =
+  -- | A node is /private/, i.e. only visible to the logged-in user.
+  Private
+  -- | A node is /shared/, i.e. only visible to the logged-in user /and/
+  -- the members of the team.
+  | Shared
+  -- | A node is /public/, i.e. visible to /all/ logged-in users.
+  | Public
+  -- | A node is /published/ when it's public and it's visible in all other
+  -- user trees. The semantic between 'Public' and 'Published' is subtle:
+  -- 'Public' refers to published nodes _of the current user_ which are visible
+  -- in his/her \"Public\" folder. 'Published' refers to published nodes
+  -- _from other users_, which will be listed in the final tree we build.
+  | Published
+  | SharedDirect
+  | PublicDirect
 
 findNodes :: (HasTreeError err, HasNodeError err)
-          => RootId
+          => UserId
+          -> RootId
           -> NodeMode
           -> [NodeType]
           -> DBCmd err [DbTreeNode]
-findNodes r Private nt       = dbTree r nt
-findNodes r Shared  nt       = findShared r NodeFolderShared nt sharedTreeUpdate
-findNodes r SharedDirect  nt = findSharedDirect r NodeFolderShared nt sharedTreeUpdate
-findNodes r Public  nt       = findShared r NodeFolderPublic nt publicTreeUpdate
-findNodes r PublicDirect  nt = findSharedDirect r NodeFolderPublic nt publicTreeUpdate
+findNodes _ r Private nt
+  = dbTree r nt
+findNodes _ r Shared  nt
+  = findShared r NodeFolderShared nt sharedTreeUpdate
+findNodes loggedInUserId r SharedDirect  nt
+  = findSharedDirect loggedInUserId r NodeFolderShared nt sharedTreeUpdate
+findNodes _ r Public  nt
+  = findShared r NodeFolderPublic nt publicTreeUpdate
+findNodes loggedInUserId r PublicDirect  nt
+  = findSharedDirect loggedInUserId r NodeFolderPublic nt publicTreeUpdate
+findNodes loggedInUserId r Published nt
+  = findPublished loggedInUserId r nt
+
+-- | Finds the /published/ nodes. Refer to the documentation for the 'NodeMode' to
+-- understand the difference between publish and published (which are the same thing,
+-- but seen from different perspectives).
+findPublished :: (HasTreeError err, HasNodeError err)
+              => UserId
+              -> RootId
+              -> [NodeType]
+              -> DBCmd err [DbTreeNode]
+findPublished loggedInUserId r nt = do
+  allPublishedRootFolders <- publishedNodeIds
+  trees <- forM allPublishedRootFolders $ \(SourceId _sharedNodeId, TargetId publicFolderId, OwnerId publicFolderOwnerId) -> do
+    case publicFolderOwnerId == r of
+      True -> pure [] -- do not list our own published nodes, as they will already show up in the public folder.
+      False -> do
+        publicNode <- getNode publicFolderId
+        -- Get the full subtree reacheable from the source id
+        sharedSubTree <- findNodes loggedInUserId publicFolderOwnerId Public nt
+        -- Now we need to artificially attach this subtree to a node which will show up in
+        -- the final tree as being owned by the logged-in user, but clearly showing as provenance
+        -- the public folder id.
+
+        let publishedNode = DbTreeNode {
+                _dt_nodeId   = publicNode ^. node_id
+              , _dt_typeId   = publicNode ^. node_typename
+              , _dt_parentId = Just r
+              , _dt_name     = publicNode ^. node_name
+              }
+
+        let detachedTree = publishedNode : (sharedSubTree & over L._head (\dt -> dt { _dt_parentId = Just $ _dt_nodeId publishedNode }))
+        pure detachedTree
+  pure $ mconcat trees
 
 ------------------------------------------------------------------------
 -- | Collaborative Nodes in the Tree
@@ -188,27 +234,20 @@ findShared r nt nts fun = do
 -- first-level subcomponents. This works in a simplified manner: fetch the node
 -- and get the tree for its parent.
 findSharedDirect :: (HasTreeError err, HasNodeError err)
-                 => RootId -> NodeType -> [NodeType] -> UpdateTree err
+                 => UserId
+                 -> RootId
+                 -> NodeType
+                 -> [NodeType]
+                 -> UpdateTree err
                  -> DBCmd err [DbTreeNode]
-findSharedDirect r nt nts fun = do
-  -- let rPrefix s = mconcat [ "[findSharedDirect] r = "
-  --                         , show r
-  --                         , ", nt = "
-  --                         , show nt
-  --                         , ", nts = "
-  --                         , show nts
-  --                         , " "
-  --                         , s ]
-  parent <- getNodeWith r (Proxy :: Proxy HyperdataAny)
-  let mParent = _node_parent_id parent
+findSharedDirect _loggedInUserId r nt nts fun = do
+  rootNode <- getNode r
+  let mParent = _node_parent_id rootNode
   case mParent of
     Nothing -> pure []
     Just parentId -> do
       foldersSharedId <- findNodesId parentId [nt]
-      -- printDebug (rPrefix "foldersSharedId") foldersSharedId
-      trees           <- mapM (updateTree nts fun) foldersSharedId
-      -- printDebug (rPrefix "trees") trees
-      pure $ concat trees
+      concat <$> mapM (updateTree nts fun) foldersSharedId
 
 
 type UpdateTree err = ParentId -> [NodeType] -> NodeId -> DBCmd err [DbTreeNode]
@@ -254,40 +293,33 @@ findNodesWithType root target through =
       isInTarget n = List.elem (fromDBid $ view dt_typeId n)
                    $ List.nub $ target <> through
 
-treeNodeToNodeId :: DbTreeNode -> NodeId
-treeNodeToNodeId = _dt_nodeId
-
 ------------------------------------------------------------------------
-------------------------------------------------------------------------
-toTree :: ( MonadError e m
-          , HasTreeError e
-          , MonadBase IO m )
-       => Map (Maybe ParentId) [DbTreeNode]
-       -> m (Tree NodeTree)
+toTree :: Map (Maybe ParentId) [NodeTree] -> Either TreeError (Tree NodeTree)
 toTree m =
     case lookup Nothing m of
         Just [root] -> pure $ toTree' m root
-        Nothing     -> treeError NoRoot
-        Just []     -> treeError EmptyRoot
-        Just r      -> treeError $ TooManyRoots (NE.fromList $ map treeNodeToNodeId r)
+        Nothing     -> Left $ NoRoot
+        Just []     -> Left $ EmptyRoot
+        Just r      -> Left $ TooManyRoots (NE.fromList $ map _nt_id r)
 
       where
-        toTree' :: Map (Maybe ParentId) [DbTreeNode]
-                -> DbTreeNode
+        toTree' :: Map (Maybe ParentId) [NodeTree]
+                -> NodeTree
                 -> Tree NodeTree
         toTree' m' root =
-          TreeN (toNodeTree root) $
+          TreeN root $
             -- Lines below are equivalent computationally but not semantically
             -- m' ^.. at (Just $ _dt_nodeId root) . _Just . each . to (toTree' m')
-            toListOf (at (Just $ _dt_nodeId root) . _Just . each . to (toTree' m')) m'
+            toListOf (at (Just $ _nt_id root) . _Just . each . to (toTree' m')) m'
 
 toNodeTree :: HasCallStack => DbTreeNode -> NodeTree
 toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromDBid tId) nId
 
 ------------------------------------------------------------------------
-toTreeParent :: [DbTreeNode]
-             -> Map (Maybe ParentId) [DbTreeNode]
-toTreeParent = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n]))
+toTreeParent :: [(Maybe ParentId, NodeTree)]
+             -> Map (Maybe ParentId) [NodeTree]
+toTreeParent = fromListWith (\a b -> nub $ a <> b) . map (\(mb_parent, n) -> (mb_parent, [n]))
+
 ------------------------------------------------------------------------
 -- toSubtreeParent' :: [DbTreeNode]
 --                 -> Map (Maybe ParentId) [DbTreeNode]
@@ -309,23 +341,16 @@ toTreeParent = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n,
 --                    , _dt_name = name }
 ------------------------------------------------------------------------
 toSubtreeParent :: RootId
-                -> [DbTreeNode]
-                -> Map (Maybe ParentId) [DbTreeNode]
-toSubtreeParent r ns = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n])) $ nullifiedParents
-  where
-    nullifiedParents = map nullifyParent ns
-    nullifyParent dt@(DbTreeNode { _dt_parentId = Nothing }) = dt
-    nullifyParent dt@(DbTreeNode { _dt_nodeId = nId
-                                 , _dt_parentId = _pId
-                                 , _dt_typeId = tId
-                                 , _dt_name = name }) =
-      if r == nId then
-        DbTreeNode { _dt_nodeId = nId
-                   , _dt_typeId = tId
-                   , _dt_parentId = Nothing
-                   , _dt_name = name }
-      else
-        dt
+                -> [(Maybe ParentId, NodeTree)]
+                -> Map (Maybe ParentId) [NodeTree]
+toSubtreeParent r = toTreeParent . map (nullifyParent r)
+
+nullifyParent :: RootId -> (Maybe ParentId, NodeTree) -> (Maybe ParentId, NodeTree)
+nullifyParent _ (Nothing, t)
+  = (Nothing, t)
+nullifyParent r (Just parent, t@(NodeTree{..}))
+  = if r == _nt_id then (Nothing, t) else (Just parent, t)
+
 ------------------------------------------------------------------------
 -- | Main DB Tree function
 dbTree :: RootId

test/Test/API/Setup.hs

@@ -35,7 +35,7 @@ import Gargantext.Database.Action.User.New
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Trigger.Init
 import Gargantext.Database.Admin.Types.Hyperdata
-import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Admin.Types.Node hiding (DEBUG)
 import Gargantext.Database.Prelude ()
 import Gargantext.Database.Query.Table.Node (getOrMkList)
 import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))