Let a Root Node, return the Tree of the Node as a directed acyclic graph
(Tree).
+-- TODO delete node, if not owned, then suppress the link only
+-- see Action/Delete.hs
-}
{-# LANGUAGE QuasiQuotes #-}
( module Gargantext.Database.Query.Tree.Error
, isDescendantOf
, isIn
- , treeDB
- , treeDB'
+ , tree
+ , TreeMode(..)
, findNodesId
, DbTreeNode(..)
, dt_name
, dt_nodeId
, dt_typeId
- , shareNodeWith
, findShared
+ , findNodes
+ , findNodesWithType
+ , NodeMode(..)
+
+ , sharedTreeUpdate
+ , dbTree
+ , updateTree
)
where
-import Control.Lens ((^..), at, each, _Just, to, set, makeLenses)
+import Control.Lens (view, toListOf, at, each, _Just, to, set, makeLenses)
import Control.Monad.Error.Class (MonadError())
-import Data.List (tail, concat)
+import Data.List (tail, concat, nub)
+import qualified Data.List as List
import Data.Map (Map, fromListWith, lookup)
+-- import Data.Monoid (mconcat)
+import Data.Proxy
+-- import qualified Data.Set as Set
import Data.Text (Text)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
+
+import Gargantext.Prelude
+import Gargantext.Core
import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
-import Gargantext.Core.Types.Individu (User(..))
-import Gargantext.Database.Admin.Types.Node -- (pgNodeId, NodeType(..))
-import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId)
-import Gargantext.Database.Admin.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
+import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId, fromNodeTypeId)
+import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny)
+import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
+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.Tree.Error
-import Gargantext.Prelude
-
-import Gargantext.Database.Query.Tree.Root (getRoot)
-import Gargantext.Database.Query.Table.NodeNode (insertNodeNode, getNodeNode)
+import Gargantext.Database.Schema.Node (NodePoly(..))
import Gargantext.Database.Schema.NodeNode (NodeNodePoly(..))
-import Gargantext.Database.Schema.Node
-
------------------------------------------------------------------------
-data DbTreeNode = DbTreeNode { _dt_nodeId :: NodeId
- , _dt_typeId :: Int
+data DbTreeNode = DbTreeNode { _dt_nodeId :: NodeId
+ , _dt_typeId :: Int
, _dt_parentId :: Maybe NodeId
, _dt_name :: Text
} deriving (Show)
makeLenses ''DbTreeNode
+
+instance Eq DbTreeNode where
+ (==) d1 d2 = (==) (_dt_nodeId d1) (_dt_nodeId d2)
+
+------------------------------------------------------------------------
+
+data TreeMode = TreeBasic | TreeAdvanced | TreeFirstLevel
+
+-- | Returns the Tree of Nodes in Database
+tree :: (HasTreeError err, HasNodeError err)
+ => TreeMode
+ -> RootId
+ -> [NodeType]
+ -> Cmd err (Tree NodeTree)
+tree TreeBasic = tree_basic
+tree TreeAdvanced = tree_advanced
+tree TreeFirstLevel = tree_first_level
+
+-- | Tree basic returns the Tree of Nodes in Database
+-- (without shared folders)
+-- keeping this for teaching purpose only
+tree_basic :: (HasTreeError err, HasNodeError err)
+
+ => RootId
+ -> [NodeType]
+ -> Cmd err (Tree NodeTree)
+tree_basic r nodeTypes =
+ (dbTree r nodeTypes <&> toTreeParent) >>= toTree
+ -- Same as (but easier to read) :
+ -- toTree =<< (toTreeParent <$> dbTree r nodeTypes)
+
+-- | Advanced mode of the Tree enables shared nodes
+tree_advanced :: (HasTreeError err, HasNodeError err)
+ => RootId
+ -> [NodeType]
+ -> Cmd 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
+ toTree $ toTreeParent (mainRoot <> sharedRoots <> publicRoots)
+
+-- | Fetch only first level of tree
+tree_first_level :: (HasTreeError err, HasNodeError err)
+ => RootId
+ -> [NodeType]
+ -> Cmd 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 Public 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
+
+------------------------------------------------------------------------
+data NodeMode = Private | Shared | Public | SharedDirect
+
+findNodes :: (HasTreeError err, HasNodeError err)
+ => RootId
+ -> NodeMode
+ -> [NodeType]
+ -> Cmd 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
+
------------------------------------------------------------------------
-- | Collaborative Nodes in the Tree
-findShared :: RootId -> [NodeType] -> Cmd err [DbTreeNode]
-findShared r nt = do
- folderSharedId <- maybe (panic "no folder found") identity
- <$> head
- <$> findNodesId r [NodeFolderShared]
- folders <- getNodeNode folderSharedId
- nodesSharedId <- mapM (\child -> sharedTree folderSharedId child nt)
- $ map _nn_node2_id folders
+-- Queries the `nodes_nodes` table.
+findShared :: HasTreeError err
+ => RootId -> NodeType -> [NodeType] -> UpdateTree err
+ -> Cmd err [DbTreeNode]
+findShared r nt nts fun = do
+ foldersSharedId <- findNodesId r [nt]
+ trees <- mapM (updateTree nts fun) foldersSharedId
+ pure $ concat trees
+
+-- | Find shared folders with "direct" access, i.e. when fetching only
+-- 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
+ -> Cmd 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_parentId parent
+ 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
+
+
+type UpdateTree err = ParentId -> [NodeType] -> NodeId -> Cmd err [DbTreeNode]
+
+updateTree :: HasTreeError err
+ => [NodeType] -> UpdateTree err -> RootId
+ -> Cmd err [DbTreeNode]
+updateTree nts fun r = do
+ folders <- getNodeNode r
+ nodesSharedId <- mapM (fun r nts)
+ $ map _nn_node2_id folders
pure $ concat nodesSharedId
-sharedTree :: ParentId -> NodeId -> [NodeType] -> Cmd err [DbTreeNode]
-sharedTree p n nt = dbTree n nt
- <&> map (\n' -> if _dt_nodeId n' == n
+
+sharedTreeUpdate :: HasTreeError err => UpdateTree err
+sharedTreeUpdate p nt n = dbTree n nt
+ <&> map (\n' -> if (view dt_nodeId n') == n
+ -- && elem (fromDBid $ _dt_typeId n') [NodeGraph]
+ -- && not (elem (fromDBid $ _dt_typeId n') [NodeFile])
then set dt_parentId (Just p) n'
else n')
+publicTreeUpdate :: HasTreeError err => UpdateTree err
+publicTreeUpdate p nt n = dbTree n nt
+ <&> map (\n' -> if _dt_nodeId n' == n
+ -- && (fromDBid $ _dt_typeId n') /= NodeGraph
+ -- && not (elem (fromDBid $ _dt_typeId n') [NodeFile])
+ then set dt_parentId (Just p) n'
+ else n')
-shareNodeWith :: NodeId -> User -> Cmd err Int64
-shareNodeWith n u = do
- r <- map _node_id <$> getRoot u
- s <- case head r of
- Nothing -> panic "no root id"
- Just r' -> findNodesId r' [NodeFolderShared]
- insertNodeNode $ map (\s' -> NodeNode s' n Nothing Nothing) s
--- TODO delete node, if not owned, then suppress the link only
-- | findNodesId returns all nodes matching nodeType but the root (Nodeuser)
findNodesId :: RootId -> [NodeType] -> Cmd err [NodeId]
<$> map _dt_nodeId
<$> dbTree r nt
-------------------------------------------------------------------------
-------------------------------------------------------------------------
--- | Returns the Tree of Nodes in Database
--- (without shared folders)
--- keeping this for teaching purpose only
-treeDB' :: HasTreeError err
- => RootId
- -> [NodeType]
- -> Cmd err (Tree NodeTree)
-treeDB' r nodeTypes =
- (dbTree r nodeTypes <&> toTreeParent) >>= toTree
- -- Same as (but easier to read) :
- -- toTree =<< (toTreeParent <$> dbTree r nodeTypes)
-
-treeDB :: HasTreeError err
- => RootId
- -> [NodeType]
- -> Cmd err (Tree NodeTree)
-treeDB r nodeTypes = do
- mainRoot <- dbTree r nodeTypes
- sharedRoots <- findShared r nodeTypes
- toTree $ toTreeParent (mainRoot <> sharedRoots)
-
+findNodesWithType :: RootId -> [NodeType] -> [NodeType] -> Cmd err [DbTreeNode]
+findNodesWithType root target through =
+ filter isInTarget <$> dbTree root through
+ where
+ isInTarget n = List.elem (fromDBid $ view dt_typeId n)
+ $ List.nub $ target <> through
+------------------------------------------------------------------------
------------------------------------------------------------------------
toTree :: ( MonadError e m
- , HasTreeError e)
+ , HasTreeError e
+ , MonadBase IO m )
=> Map (Maybe ParentId) [DbTreeNode]
-> m (Tree NodeTree)
toTree m =
case lookup Nothing m of
- Just [n] -> pure $ toTree' m n
- Nothing -> treeError NoRoot
- Just [] -> treeError EmptyRoot
- Just _ -> treeError TooManyRoots
-
- where
- toTree' :: Map (Maybe ParentId) [DbTreeNode]
- -> DbTreeNode
- -> Tree NodeTree
- toTree' m' n =
- TreeN (toNodeTree n) $
- m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
+ Just [root] -> pure $ toTree' m root
+ Nothing -> treeError NoRoot
+ Just [] -> treeError EmptyRoot
+ Just _r -> treeError TooManyRoots
+
+ where
+ toTree' :: Map (Maybe ParentId) [DbTreeNode]
+ -> DbTreeNode
+ -> Tree NodeTree
+ toTree' m' root =
+ TreeN (toNodeTree 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'
+
+ toNodeTree :: DbTreeNode
+ -> NodeTree
+ toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromNodeTypeId tId) nId
------------------------------------------------------------------------
-toNodeTree :: DbTreeNode
- -> NodeTree
-toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
- where
- nodeType = fromNodeTypeId tId
-------------------------------------------------------------------------
toTreeParent :: [DbTreeNode]
-> Map (Maybe ParentId) [DbTreeNode]
-toTreeParent = fromListWith (<>) . map (\n -> (_dt_parentId n, [n]))
+toTreeParent = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n]))
+------------------------------------------------------------------------
+-- toSubtreeParent' :: [DbTreeNode]
+-- -> Map (Maybe ParentId) [DbTreeNode]
+-- toSubtreeParent' ns = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n])) $ nullifiedParents
+-- where
+-- nodeIds = Set.fromList $ map (\n -> unNodeId $ _dt_nodeId n) ns
+-- nullifiedParents = map nullifyParent ns
+-- nullifyParent dt@(DbTreeNode { _dt_parentId = Nothing }) = dt
+-- nullifyParent dt@(DbTreeNode { _dt_nodeId = nId
+-- , _dt_parentId = Just pId
+-- , _dt_typeId = tId
+-- , _dt_name = name }) =
+-- if Set.member (unNodeId pId) nodeIds then
+-- dt
+-- else
+-- DbTreeNode { _dt_nodeId = nId
+-- , _dt_typeId = tId
+-- , _dt_parentId = Nothing
+-- , _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
------------------------------------------------------------------------
-- | Main DB Tree function
dbTree :: RootId
WHERE nn.node1_id = ?
AND nn.node2_id = ?;
|] (cId, docId)
-
-----------------------------------------------------
-
-
-