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