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