src/Gargantext/Database/Query/Tree.hs

   1 {-|
   2 Module      : Gargantext.Database.Tree
   3 Description : Tree of Resource Nodes built from Database
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Let a Root Node, return the Tree of the Node as a directed acyclic graph
  11 (Tree).
  12
  13 -- TODO delete node, if not owned, then suppress the link only
  14 -- see Action/Delete.hs
  15 -}
  16
  17 {-# LANGUAGE QuasiQuotes       #-}
  18 {-# LANGUAGE TemplateHaskell   #-}
  19
  20 module Gargantext.Database.Query.Tree
  21   ( module Gargantext.Database.Query.Tree.Error
  22   , isDescendantOf
  23   , isIn
  24   , tree
  25   , TreeMode(..)
  26   , findNodesId
  27   , DbTreeNode(..)
  28   , dt_name
  29   , dt_nodeId
  30   , dt_typeId
  31   , findShared
  32   )
  33   where
  34
  35 import Control.Lens ((^..), at, each, _Just, to, set, makeLenses)
  36 import Control.Monad.Error.Class (MonadError())
  37 import Data.List (tail, concat)
  38 import Data.Map (Map, fromListWith, lookup)
  39 import Data.Text (Text)
  40 import Database.PostgreSQL.Simple
  41 import Database.PostgreSQL.Simple.SqlQQ
  42 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
  43 import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId)
  44 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
  45 import Gargantext.Database.Admin.Types.Node -- (pgNodeId, NodeType(..))
  46 import Gargantext.Database.Prelude (Cmd, runPGSQuery)
  47 import Gargantext.Database.Query.Table.NodeNode (getNodeNode)
  48 import Gargantext.Database.Query.Tree.Error
  49 import Gargantext.Database.Schema.NodeNode (NodeNodePoly(..))
  50 import Gargantext.Prelude
  51
  52 ------------------------------------------------------------------------
  53 data DbTreeNode = DbTreeNode { _dt_nodeId :: NodeId
  54                              , _dt_typeId :: Int
  55                              , _dt_parentId :: Maybe NodeId
  56                              , _dt_name     :: Text
  57                              } deriving (Show)
  58
  59 makeLenses ''DbTreeNode
  60 ------------------------------------------------------------------------
  61
  62 data TreeMode = Basic | Advanced
  63
  64 -- | Returns the Tree of Nodes in Database
  65 tree :: HasTreeError err
  66        => TreeMode
  67        -> RootId
  68        -> [NodeType]
  69        -> Cmd err (Tree NodeTree)
  70 tree Basic    = tree_basic
  71 tree Advanced = tree_advanced
  72
  73 -- | Tree basic returns the Tree of Nodes in Database
  74 -- (without shared folders)
  75 -- keeping this for teaching purpose only
  76 tree_basic :: HasTreeError err
  77        => RootId
  78        -> [NodeType]
  79        -> Cmd err (Tree NodeTree)
  80 tree_basic r nodeTypes =
  81   (dbTree r nodeTypes <&> toTreeParent) >>= toTree
  82   -- Same as (but easier to read) :
  83   -- toTree =<< (toTreeParent <$> dbTree r nodeTypes)
  84
  85 -- | Advanced mode of the Tree enables shared nodes
  86 tree_advanced :: HasTreeError err
  87        => RootId
  88        -> [NodeType]
  89        -> Cmd err (Tree NodeTree)
  90 tree_advanced r nodeTypes = do
  91   mainRoot    <- dbTree r nodeTypes
  92   sharedRoots <- findShared r nodeTypes
  93   toTree      $ toTreeParent (mainRoot <> sharedRoots)
  94
  95 ------------------------------------------------------------------------
  96 -- | Collaborative Nodes in the Tree
  97 findShared :: RootId -> [NodeType] -> Cmd err [DbTreeNode]
  98 findShared r nt = do
  99   folderSharedId <- maybe (panic "no folder found") identity
 100                 <$> head
 101                 <$> findNodesId r [NodeFolderShared]
 102   folders <- getNodeNode folderSharedId
 103   nodesSharedId <- mapM (\child -> sharedTree folderSharedId child nt)
 104                    $ map _nn_node2_id folders
 105   pure $ concat nodesSharedId
 106
 107 sharedTree :: ParentId -> NodeId -> [NodeType] -> Cmd err [DbTreeNode]
 108 sharedTree p n nt = dbTree n nt
 109                <&> map (\n' -> if _dt_nodeId n' == n
 110                                   then set dt_parentId (Just p) n'
 111                                   else n')
 112
 113 -- | findNodesId returns all nodes matching nodeType but the root (Nodeuser)
 114 findNodesId :: RootId -> [NodeType] -> Cmd err [NodeId]
 115 findNodesId r nt = tail
 116                 <$> map _dt_nodeId
 117                 <$> dbTree r nt
 118 ------------------------------------------------------------------------
 119 ------------------------------------------------------------------------
 120 toTree :: ( MonadError e m
 121           , HasTreeError e)
 122        => Map (Maybe ParentId) [DbTreeNode]
 123        -> m (Tree NodeTree)
 124 toTree m =
 125     case lookup Nothing m of
 126         Just [n] -> pure $ toTree' m n
 127         Nothing  -> treeError NoRoot
 128         Just []  -> treeError EmptyRoot
 129         Just _   -> treeError TooManyRoots
 130
 131      where
 132       toTree' :: Map (Maybe ParentId) [DbTreeNode]
 133               -> DbTreeNode
 134               -> Tree NodeTree
 135       toTree' m' n =
 136         TreeN (toNodeTree n) $
 137           m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
 138
 139       toNodeTree :: DbTreeNode
 140                  -> NodeTree
 141       toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
 142         where
 143           nodeType = fromNodeTypeId tId
 144 ------------------------------------------------------------------------
 145 toTreeParent :: [DbTreeNode]
 146              -> Map (Maybe ParentId) [DbTreeNode]
 147 toTreeParent = fromListWith (<>) . map (\n -> (_dt_parentId n, [n]))
 148 ------------------------------------------------------------------------
 149 -- | Main DB Tree function
 150 dbTree :: RootId
 151        -> [NodeType]
 152        -> Cmd err [DbTreeNode]
 153 dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
 154   <$> runPGSQuery [sql|
 155     WITH RECURSIVE
 156         tree (id, typename, parent_id, name) AS
 157         (
 158           SELECT p.id, p.typename, p.parent_id, p.name
 159           FROM nodes AS p
 160           WHERE p.id = ?
 161
 162           UNION
 163
 164           SELECT c.id, c.typename, c.parent_id, c.name
 165           FROM nodes AS c
 166
 167           INNER JOIN tree AS s ON c.parent_id = s.id
 168            WHERE c.typename IN ?
 169         )
 170     SELECT * from tree;
 171     |] (rootId, In typename)
 172   where
 173     typename = map nodeTypeId ns
 174     ns = case nodeTypes of
 175       [] -> allNodeTypes
 176       _  -> nodeTypes
 177
 178 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 179 isDescendantOf childId rootId = (== [Only True])
 180   <$> runPGSQuery [sql|
 181                   BEGIN ;
 182                   SET TRANSACTION READ ONLY;
 183                   COMMIT;
 184
 185                   WITH RECURSIVE
 186       tree (id, parent_id) AS
 187       (
 188         SELECT c.id, c.parent_id
 189         FROM nodes AS c
 190         WHERE c.id = ?
 191
 192         UNION
 193
 194         SELECT p.id, p.parent_id
 195         FROM nodes AS p
 196         INNER JOIN tree AS t ON t.parent_id = p.id
 197
 198       )
 199   SELECT COUNT(*) = 1 from tree AS t
 200   WHERE t.id = ?;
 201   |] (childId, rootId)
 202
 203 -- TODO should we check the category?
 204 isIn :: NodeId -> DocId -> Cmd err Bool
 205 isIn cId docId = ( == [Only True])
 206   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 207     FROM nodes_nodes nn
 208       WHERE nn.node1_id = ?
 209         AND nn.node2_id = ?;
 210   |] (cId, docId)
 211 -----------------------------------------------------