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