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