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, nub)
  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
  45 import Gargantext.Database.Prelude (Cmd, runPGSQuery)
  46 import Gargantext.Database.Query.Table.NodeNode (getNodeNode)
  47 import Gargantext.Database.Query.Tree.Error
  48 import Gargantext.Database.Schema.NodeNode (NodeNodePoly(..))
  49 import Gargantext.Prelude
  50
  51 ------------------------------------------------------------------------
  52 data DbTreeNode = DbTreeNode { _dt_nodeId   :: NodeId
  53                              , _dt_typeId   :: Int
  54                              , _dt_parentId :: Maybe NodeId
  55                              , _dt_name     :: Text
  56                              } deriving (Show)
  57
  58 makeLenses ''DbTreeNode
  59
  60 instance Eq DbTreeNode where
  61   (==) d1 d2 = (==) (_dt_nodeId d1) (_dt_nodeId d2)
  62
  63 ------------------------------------------------------------------------
  64
  65 data TreeMode = Basic | Advanced
  66
  67 -- | Returns the Tree of Nodes in Database
  68 tree :: HasTreeError err
  69      => TreeMode
  70      -> RootId
  71      -> [NodeType]
  72      -> Cmd err (Tree NodeTree)
  73 tree Basic    = tree_basic
  74 tree Advanced = tree_advanced
  75
  76 -- | Tree basic returns the Tree of Nodes in Database
  77 -- (without shared folders)
  78 -- keeping this for teaching purpose only
  79 tree_basic :: HasTreeError err
  80            => RootId
  81            -> [NodeType]
  82            -> Cmd err (Tree NodeTree)
  83 tree_basic r nodeTypes =
  84   (dbTree r nodeTypes <&> toTreeParent) >>= toTree
  85   -- Same as (but easier to read) :
  86   -- toTree =<< (toTreeParent <$> dbTree r nodeTypes)
  87
  88 -- | Advanced mode of the Tree enables shared nodes
  89 tree_advanced :: HasTreeError err
  90               => RootId
  91               -> [NodeType]
  92               -> Cmd err (Tree NodeTree)
  93 tree_advanced r nodeTypes = do
  94   mainRoot    <- dbTree     r nodeTypes
  95   sharedRoots <- findShared r NodeFolderShared nodeTypes sharedTreeUpdate
  96   publicRoots <- findShared r NodeFolderPublic nodeTypes publicTreeUpdate
  97   toTree      $ toTreeParent (mainRoot <> sharedRoots <> publicRoots)
  98
  99 ------------------------------------------------------------------------
 100 -- | Collaborative Nodes in the Tree
 101 findShared :: HasTreeError err
 102            => RootId -> NodeType -> [NodeType] -> UpdateTree err
 103            -> Cmd err [DbTreeNode]
 104 findShared r nt nts fun = do
 105   foldersSharedId <- findNodesId r [nt]
 106   trees           <- mapM (updateTree nts fun) foldersSharedId
 107   pure $ concat trees
 108
 109 type UpdateTree err = ParentId -> [NodeType] -> NodeId -> Cmd err [DbTreeNode]
 110
 111 updateTree :: HasTreeError err
 112            => [NodeType] -> UpdateTree err -> RootId
 113            -> Cmd err [DbTreeNode]
 114 updateTree nts fun r = do
 115   folders       <- getNodeNode r
 116   nodesSharedId <- mapM (fun r nts)
 117                  $ map _nn_node2_id folders
 118   pure $ concat nodesSharedId
 119
 120
 121 sharedTreeUpdate :: HasTreeError err => UpdateTree err
 122 sharedTreeUpdate p nt n = dbTree n nt
 123                <&> map (\n' -> if _dt_nodeId n' == n
 124                                   -- && elem (fromNodeTypeId $ _dt_typeId n') [NodeGraph]
 125                                   -- && not (elem (fromNodeTypeId $ _dt_typeId n') [NodeFile])
 126                                   then set dt_parentId (Just p) n'
 127                                   else n')
 128
 129 publicTreeUpdate :: HasTreeError err => UpdateTree err
 130 publicTreeUpdate p nt n = dbTree n nt
 131                <&> map (\n' -> if _dt_nodeId n' == n
 132                                   -- && (fromNodeTypeId $ _dt_typeId n') /= NodeGraph
 133                                   -- && not (elem (fromNodeTypeId $ _dt_typeId n') [NodeFile])
 134                                   then set dt_parentId (Just p) n'
 135                                   else n')
 136
 137
 138
 139 -- | findNodesId returns all nodes matching nodeType but the root (Nodeuser)
 140 findNodesId :: RootId -> [NodeType] -> Cmd err [NodeId]
 141 findNodesId r nt = tail
 142                 <$> map _dt_nodeId
 143                 <$> dbTree r nt
 144 ------------------------------------------------------------------------
 145 ------------------------------------------------------------------------
 146 toTree :: ( MonadError e m
 147           , HasTreeError e)
 148        => Map (Maybe ParentId) [DbTreeNode]
 149        -> m (Tree NodeTree)
 150 toTree m =
 151     case lookup Nothing m of
 152         Just [n] -> pure $ toTree' m n
 153         Nothing  -> treeError NoRoot
 154         Just []  -> treeError EmptyRoot
 155         Just _   -> treeError TooManyRoots
 156
 157      where
 158       toTree' :: Map (Maybe ParentId) [DbTreeNode]
 159               -> DbTreeNode
 160               -> Tree NodeTree
 161       toTree' m' n =
 162         TreeN (toNodeTree n) $
 163           m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
 164
 165       toNodeTree :: DbTreeNode
 166                  -> NodeTree
 167       toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
 168         where
 169           nodeType = fromNodeTypeId tId
 170 ------------------------------------------------------------------------
 171 toTreeParent :: [DbTreeNode]
 172              -> Map (Maybe ParentId) [DbTreeNode]
 173 toTreeParent = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n]))
 174 ------------------------------------------------------------------------
 175 -- | Main DB Tree function
 176 dbTree :: RootId
 177        -> [NodeType]
 178        -> Cmd err [DbTreeNode]
 179 dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
 180   <$> runPGSQuery [sql|
 181     WITH RECURSIVE
 182         tree (id, typename, parent_id, name) AS
 183         (
 184           SELECT p.id, p.typename, p.parent_id, p.name
 185           FROM nodes AS p
 186           WHERE p.id = ?
 187
 188           UNION
 189
 190           SELECT c.id, c.typename, c.parent_id, c.name
 191           FROM nodes AS c
 192
 193           INNER JOIN tree AS s ON c.parent_id = s.id
 194            WHERE c.typename IN ?
 195         )
 196     SELECT * from tree;
 197     |] (rootId, In typename)
 198   where
 199     typename = map nodeTypeId ns
 200     ns = case nodeTypes of
 201       [] -> allNodeTypes
 202       _  -> nodeTypes
 203
 204 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 205 isDescendantOf childId rootId = (== [Only True])
 206   <$> runPGSQuery [sql|
 207                   BEGIN ;
 208                   SET TRANSACTION READ ONLY;
 209                   COMMIT;
 210
 211                   WITH RECURSIVE
 212       tree (id, parent_id) AS
 213       (
 214         SELECT c.id, c.parent_id
 215         FROM nodes AS c
 216         WHERE c.id = ?
 217
 218         UNION
 219
 220         SELECT p.id, p.parent_id
 221         FROM nodes AS p
 222         INNER JOIN tree AS t ON t.parent_id = p.id
 223
 224       )
 225   SELECT COUNT(*) = 1 from tree AS t
 226   WHERE t.id = ?;
 227   |] (childId, rootId)
 228
 229 -- TODO should we check the category?
 230 isIn :: NodeId -> DocId -> Cmd err Bool
 231 isIn cId docId = ( == [Only True])
 232   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 233     FROM nodes_nodes nn
 234       WHERE nn.node1_id = ?
 235         AND nn.node2_id = ?;
 236   |] (cId, docId)
 237 -----------------------------------------------------