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, fromNodeTypeId)
  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 NodeFolderShared nodeTypes sharedTreeUpdate
  93   publicRoots <- findShared r NodeFolderPublic nodeTypes publicTreeUpdate
  94   toTree      $ toTreeParent (mainRoot <> sharedRoots <> publicRoots)
  95
  96 ------------------------------------------------------------------------
  97 -- | Collaborative Nodes in the Tree
  98 findShared :: RootId -> NodeType -> [NodeType] -> UpdateTree err -> Cmd err [DbTreeNode]
  99 findShared r nt nts fun = do
 100   folderSharedId <- maybe (panic "no folder found") identity
 101                 <$> head
 102                 <$> findNodesId r [nt]
 103   folders       <- getNodeNode folderSharedId
 104   nodesSharedId <- mapM (\child -> fun folderSharedId child nts)
 105                  $ map _nn_node2_id folders
 106   pure $ concat nodesSharedId
 107
 108 type UpdateTree err = ParentId -> NodeId -> [NodeType] -> Cmd err [DbTreeNode]
 109
 110 sharedTreeUpdate :: ParentId -> NodeId -> [NodeType] -> Cmd err [DbTreeNode]
 111 sharedTreeUpdate p n nt = dbTree n nt
 112                <&> map (\n' -> if _dt_nodeId n' == n
 113                                   then set dt_parentId (Just p) n'
 114                                   else n')
 115
 116 publicTreeUpdate :: ParentId -> NodeId -> [NodeType] -> Cmd err [DbTreeNode]
 117 publicTreeUpdate p n nt = dbTree n nt
 118                <&> map (\n' -> if _dt_nodeId n' == n
 119                                 -- && (fromNodeTypeId $ _dt_typeId n') /= NodeFolderPublic
 120                                   then set dt_parentId (Just p) n'
 121                                   else n')
 122
 123
 124
 125 -- | findNodesId returns all nodes matching nodeType but the root (Nodeuser)
 126 findNodesId :: RootId -> [NodeType] -> Cmd err [NodeId]
 127 findNodesId r nt = tail
 128                 <$> map _dt_nodeId
 129                 <$> dbTree r nt
 130 ------------------------------------------------------------------------
 131 ------------------------------------------------------------------------
 132 toTree :: ( MonadError e m
 133           , HasTreeError e)
 134        => Map (Maybe ParentId) [DbTreeNode]
 135        -> m (Tree NodeTree)
 136 toTree m =
 137     case lookup Nothing m of
 138         Just [n] -> pure $ toTree' m n
 139         Nothing  -> treeError NoRoot
 140         Just []  -> treeError EmptyRoot
 141         Just _   -> treeError TooManyRoots
 142
 143      where
 144       toTree' :: Map (Maybe ParentId) [DbTreeNode]
 145               -> DbTreeNode
 146               -> Tree NodeTree
 147       toTree' m' n =
 148         TreeN (toNodeTree n) $
 149           m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
 150
 151       toNodeTree :: DbTreeNode
 152                  -> NodeTree
 153       toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
 154         where
 155           nodeType = fromNodeTypeId tId
 156 ------------------------------------------------------------------------
 157 toTreeParent :: [DbTreeNode]
 158              -> Map (Maybe ParentId) [DbTreeNode]
 159 toTreeParent = fromListWith (<>) . map (\n -> (_dt_parentId n, [n]))
 160 ------------------------------------------------------------------------
 161 -- | Main DB Tree function
 162 dbTree :: RootId
 163        -> [NodeType]
 164        -> Cmd err [DbTreeNode]
 165 dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
 166   <$> runPGSQuery [sql|
 167     WITH RECURSIVE
 168         tree (id, typename, parent_id, name) AS
 169         (
 170           SELECT p.id, p.typename, p.parent_id, p.name
 171           FROM nodes AS p
 172           WHERE p.id = ?
 173
 174           UNION
 175
 176           SELECT c.id, c.typename, c.parent_id, c.name
 177           FROM nodes AS c
 178
 179           INNER JOIN tree AS s ON c.parent_id = s.id
 180            WHERE c.typename IN ?
 181         )
 182     SELECT * from tree;
 183     |] (rootId, In typename)
 184   where
 185     typename = map nodeTypeId ns
 186     ns = case nodeTypes of
 187       [] -> allNodeTypes
 188       _  -> nodeTypes
 189
 190 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 191 isDescendantOf childId rootId = (== [Only True])
 192   <$> runPGSQuery [sql|
 193                   BEGIN ;
 194                   SET TRANSACTION READ ONLY;
 195                   COMMIT;
 196
 197                   WITH RECURSIVE
 198       tree (id, parent_id) AS
 199       (
 200         SELECT c.id, c.parent_id
 201         FROM nodes AS c
 202         WHERE c.id = ?
 203
 204         UNION
 205
 206         SELECT p.id, p.parent_id
 207         FROM nodes AS p
 208         INNER JOIN tree AS t ON t.parent_id = p.id
 209
 210       )
 211   SELECT COUNT(*) = 1 from tree AS t
 212   WHERE t.id = ?;
 213   |] (childId, rootId)
 214
 215 -- TODO should we check the category?
 216 isIn :: NodeId -> DocId -> Cmd err Bool
 217 isIn cId docId = ( == [Only True])
 218   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 219     FROM nodes_nodes nn
 220       WHERE nn.node1_id = ?
 221         AND nn.node2_id = ?;
 222   |] (cId, docId)
 223 -----------------------------------------------------