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   , treeDB
  25   , treeDB'
  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)
  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 -- | Returns the Tree of Nodes in Database
  62 -- (without shared folders)
  63 -- keeping this for teaching purpose only
  64 treeDB' :: HasTreeError err
  65        => RootId
  66        -> [NodeType]
  67        -> Cmd err (Tree NodeTree)
  68 treeDB' r nodeTypes =
  69   (dbTree r nodeTypes <&> toTreeParent) >>= toTree
  70   -- Same as (but easier to read) :
  71   -- toTree =<< (toTreeParent <$> dbTree r nodeTypes)
  72
  73 treeDB :: HasTreeError err
  74        => RootId
  75        -> [NodeType]
  76        -> Cmd err (Tree NodeTree)
  77 treeDB r nodeTypes = do
  78   mainRoot    <- dbTree r nodeTypes
  79   sharedRoots <- findShared r nodeTypes
  80   toTree      $ toTreeParent (mainRoot <> sharedRoots)
  81
  82 ------------------------------------------------------------------------
  83 -- | Collaborative Nodes in the Tree
  84 findShared :: RootId -> [NodeType] -> Cmd err [DbTreeNode]
  85 findShared r nt = do
  86   folderSharedId <- maybe (panic "no folder found") identity
  87                 <$> head
  88                 <$> findNodesId r [NodeFolderShared]
  89   folders <- getNodeNode folderSharedId
  90   nodesSharedId <- mapM (\child -> sharedTree folderSharedId child nt)
  91                    $ map _nn_node2_id folders
  92   pure $ concat nodesSharedId
  93
  94 sharedTree :: ParentId -> NodeId -> [NodeType] -> Cmd err [DbTreeNode]
  95 sharedTree p n nt = dbTree n nt
  96                <&> map (\n' -> if _dt_nodeId n' == n
  97                                   then set dt_parentId (Just p) n'
  98                                   else n')
  99
 100 -- | findNodesId returns all nodes matching nodeType but the root (Nodeuser)
 101 findNodesId :: RootId -> [NodeType] -> Cmd err [NodeId]
 102 findNodesId r nt = tail
 103                 <$> map _dt_nodeId
 104                 <$> dbTree r nt
 105 ------------------------------------------------------------------------
 106 ------------------------------------------------------------------------
 107 toTree :: ( MonadError e m
 108           , HasTreeError e)
 109        => Map (Maybe ParentId) [DbTreeNode]
 110        -> m (Tree NodeTree)
 111 toTree m =
 112     case lookup Nothing m of
 113         Just [n] -> pure $ toTree' m n
 114         Nothing  -> treeError NoRoot
 115         Just []  -> treeError EmptyRoot
 116         Just _   -> treeError TooManyRoots
 117
 118      where
 119       toTree' :: Map (Maybe ParentId) [DbTreeNode]
 120               -> DbTreeNode
 121               -> Tree NodeTree
 122       toTree' m' n =
 123         TreeN (toNodeTree n) $
 124           m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
 125
 126       toNodeTree :: DbTreeNode
 127                  -> NodeTree
 128       toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
 129         where
 130           nodeType = fromNodeTypeId tId
 131 ------------------------------------------------------------------------
 132 toTreeParent :: [DbTreeNode]
 133              -> Map (Maybe ParentId) [DbTreeNode]
 134 toTreeParent = fromListWith (<>) . map (\n -> (_dt_parentId n, [n]))
 135 ------------------------------------------------------------------------
 136 -- | Main DB Tree function
 137 dbTree :: RootId
 138        -> [NodeType]
 139        -> Cmd err [DbTreeNode]
 140 dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
 141   <$> runPGSQuery [sql|
 142     WITH RECURSIVE
 143         tree (id, typename, parent_id, name) AS
 144         (
 145           SELECT p.id, p.typename, p.parent_id, p.name
 146           FROM nodes AS p
 147           WHERE p.id = ?
 148
 149           UNION
 150
 151           SELECT c.id, c.typename, c.parent_id, c.name
 152           FROM nodes AS c
 153
 154           INNER JOIN tree AS s ON c.parent_id = s.id
 155            WHERE c.typename IN ?
 156         )
 157     SELECT * from tree;
 158     |] (rootId, In typename)
 159   where
 160     typename = map nodeTypeId ns
 161     ns = case nodeTypes of
 162       [] -> allNodeTypes
 163       _  -> nodeTypes
 164
 165 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 166 isDescendantOf childId rootId = (== [Only True])
 167   <$> runPGSQuery [sql|
 168                   BEGIN ;
 169                   SET TRANSACTION READ ONLY;
 170                   COMMIT;
 171
 172                   WITH RECURSIVE
 173       tree (id, parent_id) AS
 174       (
 175         SELECT c.id, c.parent_id
 176         FROM nodes AS c
 177         WHERE c.id = ?
 178
 179         UNION
 180
 181         SELECT p.id, p.parent_id
 182         FROM nodes AS p
 183         INNER JOIN tree AS t ON t.parent_id = p.id
 184
 185       )
 186   SELECT COUNT(*) = 1 from tree AS t
 187   WHERE t.id = ?;
 188   |] (childId, rootId)
 189
 190 -- TODO should we check the category?
 191 isIn :: NodeId -> DocId -> Cmd err Bool
 192 isIn cId docId = ( == [Only True])
 193   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 194     FROM nodes_nodes nn
 195       WHERE nn.node1_id = ?
 196         AND nn.node2_id = ?;
 197   |] (cId, docId)
 198 -----------------------------------------------------