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 ((^..), 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 Private r nodeTypes
  97   sharedRoots <- findNodes Shared  r nodeTypes
  98   publicRoots <- findNodes Public  r nodeTypes
  99   toTree      $ toTreeParent (mainRoot <> sharedRoots <> publicRoots)
 100
 101 ------------------------------------------------------------------------
 102 data NodeMode = Private | Shared | Public
 103
 104 findNodes :: HasTreeError err
 105           => NodeMode
 106           -> RootId -> [NodeType]
 107           -> Cmd err [DbTreeNode]
 108 findNodes Private r nt = dbTree r nt
 109 findNodes Shared  r nt = findShared r NodeFolderShared nt sharedTreeUpdate
 110 findNodes Public  r nt = findShared r NodeFolderPublic nt publicTreeUpdate
 111
 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 type UpdateTree err = ParentId -> [NodeType] -> NodeId -> Cmd err [DbTreeNode]
 124
 125 updateTree :: HasTreeError err
 126            => [NodeType] -> UpdateTree err -> RootId
 127            -> Cmd err [DbTreeNode]
 128 updateTree nts fun r = do
 129   folders       <- getNodeNode r
 130   nodesSharedId <- mapM (fun r nts)
 131                  $ map _nn_node2_id folders
 132   pure $ concat nodesSharedId
 133
 134
 135 sharedTreeUpdate :: HasTreeError err => UpdateTree err
 136 sharedTreeUpdate p nt n = dbTree n nt
 137                <&> map (\n' -> if _dt_nodeId n' == n
 138                                   -- && elem (fromNodeTypeId $ _dt_typeId n') [NodeGraph]
 139                                   -- && not (elem (fromNodeTypeId $ _dt_typeId n') [NodeFile])
 140                                   then set dt_parentId (Just p) n'
 141                                   else n')
 142
 143 publicTreeUpdate :: HasTreeError err => UpdateTree err
 144 publicTreeUpdate p nt n = dbTree n nt
 145                <&> map (\n' -> if _dt_nodeId n' == n
 146                                   -- && (fromNodeTypeId $ _dt_typeId n') /= NodeGraph
 147                                   -- && not (elem (fromNodeTypeId $ _dt_typeId n') [NodeFile])
 148                                   then set dt_parentId (Just p) n'
 149                                   else n')
 150
 151
 152
 153 -- | findNodesId returns all nodes matching nodeType but the root (Nodeuser)
 154 findNodesId :: RootId -> [NodeType] -> Cmd err [NodeId]
 155 findNodesId r nt = tail
 156                 <$> map _dt_nodeId
 157                 <$> dbTree r nt
 158 ------------------------------------------------------------------------
 159 ------------------------------------------------------------------------
 160 toTree :: ( MonadError e m
 161           , HasTreeError e)
 162        => Map (Maybe ParentId) [DbTreeNode]
 163        -> m (Tree NodeTree)
 164 toTree m =
 165     case lookup Nothing m of
 166         Just [n] -> pure $ toTree' m n
 167         Nothing  -> treeError NoRoot
 168         Just []  -> treeError EmptyRoot
 169         Just _   -> treeError TooManyRoots
 170
 171      where
 172       toTree' :: Map (Maybe ParentId) [DbTreeNode]
 173               -> DbTreeNode
 174               -> Tree NodeTree
 175       toTree' m' n =
 176         TreeN (toNodeTree n) $
 177           m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
 178
 179       toNodeTree :: DbTreeNode
 180                  -> NodeTree
 181       toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
 182         where
 183           nodeType = fromNodeTypeId tId
 184 ------------------------------------------------------------------------
 185 toTreeParent :: [DbTreeNode]
 186              -> Map (Maybe ParentId) [DbTreeNode]
 187 toTreeParent = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n]))
 188 ------------------------------------------------------------------------
 189 -- | Main DB Tree function
 190 dbTree :: RootId
 191        -> [NodeType]
 192        -> Cmd err [DbTreeNode]
 193 dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
 194   <$> runPGSQuery [sql|
 195     WITH RECURSIVE
 196         tree (id, typename, parent_id, name) AS
 197         (
 198           SELECT p.id, p.typename, p.parent_id, p.name
 199           FROM nodes AS p
 200           WHERE p.id = ?
 201
 202           UNION
 203
 204           SELECT c.id, c.typename, c.parent_id, c.name
 205           FROM nodes AS c
 206
 207           INNER JOIN tree AS s ON c.parent_id = s.id
 208            WHERE c.typename IN ?
 209         )
 210     SELECT * from tree;
 211     |] (rootId, In typename)
 212   where
 213     typename = map nodeTypeId ns
 214     ns = case nodeTypes of
 215       [] -> allNodeTypes
 216       _  -> nodeTypes
 217
 218 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 219 isDescendantOf childId rootId = (== [Only True])
 220   <$> runPGSQuery [sql|
 221                   BEGIN ;
 222                   SET TRANSACTION READ ONLY;
 223                   COMMIT;
 224
 225                   WITH RECURSIVE
 226       tree (id, parent_id) AS
 227       (
 228         SELECT c.id, c.parent_id
 229         FROM nodes AS c
 230         WHERE c.id = ?
 231
 232         UNION
 233
 234         SELECT p.id, p.parent_id
 235         FROM nodes AS p
 236         INNER JOIN tree AS t ON t.parent_id = p.id
 237
 238       )
 239   SELECT COUNT(*) = 1 from tree AS t
 240   WHERE t.id = ?;
 241   |] (childId, rootId)
 242
 243 -- TODO should we check the category?
 244 isIn :: NodeId -> DocId -> Cmd err Bool
 245 isIn cId docId = ( == [Only True])
 246   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 247     FROM nodes_nodes nn
 248       WHERE nn.node1_id = ?
 249         AND nn.node2_id = ?;
 250   |] (cId, docId)
 251 -----------------------------------------------------