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 ({-(^..)-} 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 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           -- | Lines below are equal computationally but not semantically
 178           -- m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
 179           toListOf (at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')) m'
 180
 181       toNodeTree :: DbTreeNode
 182                  -> NodeTree
 183       toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromNodeTypeId tId) nId
 184
 185 ------------------------------------------------------------------------
 186 toTreeParent :: [DbTreeNode]
 187              -> Map (Maybe ParentId) [DbTreeNode]
 188 toTreeParent = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n]))
 189 ------------------------------------------------------------------------
 190 -- | Main DB Tree function
 191 dbTree :: RootId
 192        -> [NodeType]
 193        -> Cmd err [DbTreeNode]
 194 dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
 195   <$> runPGSQuery [sql|
 196     WITH RECURSIVE
 197         tree (id, typename, parent_id, name) AS
 198         (
 199           SELECT p.id, p.typename, p.parent_id, p.name
 200           FROM nodes AS p
 201           WHERE p.id = ?
 202
 203           UNION
 204
 205           SELECT c.id, c.typename, c.parent_id, c.name
 206           FROM nodes AS c
 207
 208           INNER JOIN tree AS s ON c.parent_id = s.id
 209            WHERE c.typename IN ?
 210         )
 211     SELECT * from tree;
 212     |] (rootId, In typename)
 213   where
 214     typename = map nodeTypeId ns
 215     ns = case nodeTypes of
 216       [] -> allNodeTypes
 217       _  -> nodeTypes
 218
 219 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 220 isDescendantOf childId rootId = (== [Only True])
 221   <$> runPGSQuery [sql|
 222                   BEGIN ;
 223                   SET TRANSACTION READ ONLY;
 224                   COMMIT;
 225
 226                   WITH RECURSIVE
 227       tree (id, parent_id) AS
 228       (
 229         SELECT c.id, c.parent_id
 230         FROM nodes AS c
 231         WHERE c.id = ?
 232
 233         UNION
 234
 235         SELECT p.id, p.parent_id
 236         FROM nodes AS p
 237         INNER JOIN tree AS t ON t.parent_id = p.id
 238
 239       )
 240   SELECT COUNT(*) = 1 from tree AS t
 241   WHERE t.id = ?;
 242   |] (childId, rootId)
 243
 244 -- TODO should we check the category?
 245 isIn :: NodeId -> DocId -> Cmd err Bool
 246 isIn cId docId = ( == [Only True])
 247   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 248     FROM nodes_nodes nn
 249       WHERE nn.node1_id = ?
 250         AND nn.node2_id = ?;
 251   |] (cId, docId)
 252 -----------------------------------------------------