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