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