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 (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   toTree      $ toTreeParent (mainRoot <> sharedRoots <> publicRoots)
 121
 122 -- | Fetch only first level of tree
 123 tree_first_level :: (HasTreeError err, HasNodeError err)
 124                  => RootId
 125                  -> [NodeType]
 126                  -> Cmd err (Tree NodeTree)
 127 tree_first_level r nodeTypes = do
 128   -- let rPrefix s = mconcat [ "[tree_first_level] root = "
 129   --                         , show r
 130   --                         , ", nodeTypes = "
 131   --                         , show nodeTypes
 132   --                         , " "
 133   --                         , s ]
 134   mainRoot    <- findNodes r Private nodeTypes
 135   -- printDebug (rPrefix "mainRoot") mainRoot
 136   publicRoots <- findNodes r PublicDirect  nodeTypes
 137   -- printDebug (rPrefix "publicRoots") publicRoots
 138   sharedRoots <- findNodes r SharedDirect  nodeTypes
 139   -- printDebug (rPrefix "sharedRoots") sharedRoots
 140   ret <- toTree $ toSubtreeParent r (mainRoot <> sharedRoots <> publicRoots)
 141   -- printDebug (rPrefix "tree") ret
 142   pure ret
 143
 144 ------------------------------------------------------------------------
 145 data NodeMode = Private | Shared | Public | SharedDirect | PublicDirect
 146
 147 findNodes :: (HasTreeError err, HasNodeError err)
 148           => RootId
 149           -> NodeMode
 150           -> [NodeType]
 151           -> Cmd err [DbTreeNode]
 152 findNodes r Private nt       = dbTree r nt
 153 findNodes r Shared  nt       = findShared r NodeFolderShared nt sharedTreeUpdate
 154 findNodes r SharedDirect  nt = findSharedDirect r NodeFolderShared nt sharedTreeUpdate
 155 findNodes r Public  nt       = findShared r NodeFolderPublic nt publicTreeUpdate
 156 findNodes r PublicDirect  nt = findSharedDirect r NodeFolderPublic nt publicTreeUpdate
 157
 158 ------------------------------------------------------------------------
 159 -- | Collaborative Nodes in the Tree
 160 --   Queries the `nodes_nodes` table.
 161 findShared :: HasTreeError err
 162            => RootId -> NodeType -> [NodeType] -> UpdateTree err
 163            -> Cmd err [DbTreeNode]
 164 findShared r nt nts fun = do
 165   foldersSharedId <- findNodesId r [nt]
 166   trees           <- mapM (updateTree nts fun) foldersSharedId
 167   pure $ concat trees
 168
 169 -- | Find shared folders with "direct" access, i.e. when fetching only
 170 -- first-level subcomponents. This works in a simplified manner: fetch the node
 171 -- and get the tree for its parent.
 172 findSharedDirect :: (HasTreeError err, HasNodeError err)
 173                  => RootId -> NodeType -> [NodeType] -> UpdateTree err
 174                  -> Cmd err [DbTreeNode]
 175 findSharedDirect r nt nts fun = do
 176   -- let rPrefix s = mconcat [ "[findSharedDirect] r = "
 177   --                         , show r
 178   --                         , ", nt = "
 179   --                         , show nt
 180   --                         , ", nts = "
 181   --                         , show nts
 182   --                         , " "
 183   --                         , s ]
 184   parent <- getNodeWith r (Proxy :: Proxy HyperdataAny)
 185   let mParent = _node_parentId parent
 186   case mParent of
 187     Nothing -> pure []
 188     Just parentId -> do
 189       foldersSharedId <- findNodesId parentId [nt]
 190       -- printDebug (rPrefix "foldersSharedId") foldersSharedId
 191       trees           <- mapM (updateTree nts fun) foldersSharedId
 192       -- printDebug (rPrefix "trees") trees
 193       pure $ concat trees
 194
 195
 196 type UpdateTree err = ParentId -> [NodeType] -> NodeId -> Cmd err [DbTreeNode]
 197
 198 updateTree :: HasTreeError err
 199            => [NodeType] -> UpdateTree err -> RootId
 200            -> Cmd err [DbTreeNode]
 201 updateTree nts fun r = do
 202   folders       <- getNodeNode r
 203   nodesSharedId <- mapM (fun r nts)
 204                  $ map _nn_node2_id folders
 205   pure $ concat nodesSharedId
 206
 207
 208 sharedTreeUpdate :: HasTreeError err => UpdateTree err
 209 sharedTreeUpdate p nt n = dbTree n nt
 210                <&> map (\n' -> if (view dt_nodeId n') == n
 211                                   -- && elem (fromDBid $ _dt_typeId n') [NodeGraph]
 212                                   -- && not (elem (fromDBid $ _dt_typeId n') [NodeFile])
 213                                   then set dt_parentId (Just p) n'
 214                                   else n')
 215
 216 publicTreeUpdate :: HasTreeError err => UpdateTree err
 217 publicTreeUpdate p nt n = dbTree n nt
 218                <&> map (\n' -> if _dt_nodeId n' == n
 219                                   -- && (fromDBid $ _dt_typeId n') /= NodeGraph
 220                                   -- && not (elem (fromDBid $ _dt_typeId n') [NodeFile])
 221                                   then set dt_parentId (Just p) n'
 222                                   else n')
 223
 224
 225
 226 -- | findNodesId returns all nodes matching nodeType but the root (Nodeuser)
 227 findNodesId :: RootId -> [NodeType] -> Cmd err [NodeId]
 228 findNodesId r nt = tail
 229                 <$> map _dt_nodeId
 230                 <$> dbTree r nt
 231
 232 findNodesWithType :: RootId -> [NodeType] -> [NodeType] -> Cmd err [DbTreeNode]
 233 findNodesWithType root target through =
 234   filter isInTarget <$> dbTree root through
 235     where
 236       isInTarget n = List.elem (fromDBid $ view dt_typeId n)
 237                    $ List.nub $ target <> through
 238
 239 ------------------------------------------------------------------------
 240 ------------------------------------------------------------------------
 241 toTree :: ( MonadError e m
 242           , HasTreeError e
 243           , MonadBase IO m )
 244        => Map (Maybe ParentId) [DbTreeNode]
 245        -> m (Tree NodeTree)
 246 toTree m =
 247     case lookup Nothing m of
 248         Just [root] -> pure $ toTree' m root
 249         Nothing     -> treeError NoRoot
 250         Just []     -> treeError EmptyRoot
 251         Just _r     -> treeError TooManyRoots
 252
 253       where
 254         toTree' :: Map (Maybe ParentId) [DbTreeNode]
 255                 -> DbTreeNode
 256                 -> Tree NodeTree
 257         toTree' m' root =
 258           TreeN (toNodeTree root) $
 259             -- | Lines below are equivalent computationally but not semantically
 260             -- m' ^.. at (Just $ _dt_nodeId root) . _Just . each . to (toTree' m')
 261             toListOf (at (Just $ _dt_nodeId root) . _Just . each . to (toTree' m')) m'
 262
 263         toNodeTree :: DbTreeNode
 264                    -> NodeTree
 265         toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromNodeTypeId tId) nId
 266
 267 ------------------------------------------------------------------------
 268 toTreeParent :: [DbTreeNode]
 269              -> Map (Maybe ParentId) [DbTreeNode]
 270 toTreeParent = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n]))
 271 ------------------------------------------------------------------------
 272 -- toSubtreeParent' :: [DbTreeNode]
 273 --                 -> Map (Maybe ParentId) [DbTreeNode]
 274 -- toSubtreeParent' ns = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n])) $ nullifiedParents
 275 --   where
 276 --     nodeIds = Set.fromList $ map (\n -> unNodeId $ _dt_nodeId n) ns
 277 --     nullifiedParents = map nullifyParent ns
 278 --     nullifyParent dt@(DbTreeNode { _dt_parentId = Nothing }) = dt
 279 --     nullifyParent dt@(DbTreeNode { _dt_nodeId = nId
 280 --                                  , _dt_parentId = Just pId
 281 --                                  , _dt_typeId = tId
 282 --                                  , _dt_name = name }) =
 283 --       if Set.member (unNodeId pId) nodeIds then
 284 --         dt
 285 --       else
 286 --         DbTreeNode { _dt_nodeId = nId
 287 --                    , _dt_typeId = tId
 288 --                    , _dt_parentId = Nothing
 289 --                    , _dt_name = name }
 290 ------------------------------------------------------------------------
 291 toSubtreeParent :: RootId
 292                 -> [DbTreeNode]
 293                 -> Map (Maybe ParentId) [DbTreeNode]
 294 toSubtreeParent r ns = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n])) $ nullifiedParents
 295   where
 296     nullifiedParents = map nullifyParent ns
 297     nullifyParent dt@(DbTreeNode { _dt_parentId = Nothing }) = dt
 298     nullifyParent dt@(DbTreeNode { _dt_nodeId = nId
 299                                  , _dt_parentId = _pId
 300                                  , _dt_typeId = tId
 301                                  , _dt_name = name }) =
 302       if r == nId then
 303         DbTreeNode { _dt_nodeId = nId
 304                    , _dt_typeId = tId
 305                    , _dt_parentId = Nothing
 306                    , _dt_name = name }
 307       else
 308         dt
 309 ------------------------------------------------------------------------
 310 -- | Main DB Tree function
 311 dbTree :: RootId
 312        -> [NodeType]
 313        -> Cmd err [DbTreeNode]
 314 dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
 315   <$> runPGSQuery [sql|
 316     WITH RECURSIVE
 317         tree (id, typename, parent_id, name) AS
 318         (
 319           SELECT p.id, p.typename, p.parent_id, p.name
 320           FROM nodes AS p
 321           WHERE p.id = ?
 322
 323           UNION
 324
 325           SELECT c.id, c.typename, c.parent_id, c.name
 326           FROM nodes AS c
 327
 328           INNER JOIN tree AS s ON c.parent_id = s.id
 329            WHERE c.typename IN ?
 330         )
 331     SELECT * from tree;
 332     |] (rootId, In typename)
 333   where
 334     typename = map nodeTypeId ns
 335     ns = case nodeTypes of
 336       [] -> allNodeTypes
 337       _  -> nodeTypes
 338
 339 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 340 isDescendantOf childId rootId = (== [Only True])
 341   <$> runPGSQuery [sql|
 342                   BEGIN ;
 343                   SET TRANSACTION READ ONLY;
 344                   COMMIT;
 345
 346                   WITH RECURSIVE
 347       tree (id, parent_id) AS
 348       (
 349         SELECT c.id, c.parent_id
 350         FROM nodes AS c
 351         WHERE c.id = ?
 352
 353         UNION
 354
 355         SELECT p.id, p.parent_id
 356         FROM nodes AS p
 357         INNER JOIN tree AS t ON t.parent_id = p.id
 358
 359       )
 360   SELECT COUNT(*) = 1 from tree AS t
 361   WHERE t.id = ?;
 362   |] (childId, rootId)
 363
 364 -- TODO should we check the category?
 365 isIn :: NodeId -> DocId -> Cmd err Bool
 366 isIn cId docId = ( == [Only True])
 367   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 368     FROM nodes_nodes nn
 369       WHERE nn.node1_id = ?
 370         AND nn.node2_id = ?;
 371   |] (cId, docId)
 372 -----------------------------------------------------