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