src/Gargantext/Database/Action/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 -}
  14
  15 {-# LANGUAGE FlexibleContexts  #-}
  16 {-# LANGUAGE NoImplicitPrelude #-}
  17 {-# LANGUAGE QuasiQuotes       #-}
  18 {-# LANGUAGE RankNTypes        #-}
  19
  20 module Gargantext.Database.Action.Query.Tree
  21   ( treeDB
  22   , TreeError(..)
  23   , HasTreeError(..)
  24   , dbTree
  25   , toNodeTree
  26   , DbTreeNode
  27   , isDescendantOf
  28   , isIn
  29   ) where
  30
  31 import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
  32 import Control.Monad.Error.Class (MonadError(throwError))
  33 import Data.Map (Map, fromListWith, lookup)
  34 import Data.Text (Text)
  35 import Database.PostgreSQL.Simple
  36 import Database.PostgreSQL.Simple.SqlQQ
  37
  38 import Gargantext.Prelude
  39 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
  40 import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId)
  41 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
  42 import Gargantext.Database.Admin.Types.Errors
  43 import Gargantext.Database.Admin.Utils (Cmd, runPGSQuery)
  44 import Gargantext.Database.Action.Query.Node
  45 import Gargantext.Database.Action.Query.User
  46
  47 ------------------------------------------------------------------------
  48 -- import Gargantext.Database.Utils (runCmdDev)
  49 -- treeTest :: IO (Tree NodeTree)
  50 -- treeTest = runCmdDev $ treeDB 347474
  51 ------------------------------------------------------------------------
  52
  53 mkRoot :: HasNodeError err
  54        => User
  55        -> Cmd err [RootId]
  56 mkRoot user = do
  57
  58   uid <- getUserId user
  59
  60   let una = "username"
  61
  62   case uid > 0 of
  63      False -> nodeError NegativeId
  64      True  -> do
  65        rs <- mkNodeWithParent NodeUser Nothing uid una
  66        _ <- case rs of
  67          [r] -> do
  68            _ <- mkNodeWithParent NodeFolderPrivate (Just r) uid una
  69            _ <- mkNodeWithParent NodeFolderShared  (Just r) uid una
  70            _ <- mkNodeWithParent NodeFolderPublic  (Just r) uid una
  71            pure rs
  72          _   -> pure rs
  73        pure rs
  74
  75
  76 ------------------------------------------------------------------------
  77 data TreeError = NoRoot | EmptyRoot | TooManyRoots
  78   deriving (Show)
  79
  80 class HasTreeError e where
  81   _TreeError :: Prism' e TreeError
  82
  83 treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
  84 treeError te = throwError $ _TreeError # te
  85
  86 -- | Returns the Tree of Nodes in Database
  87 treeDB :: HasTreeError err => RootId -> [NodeType] -> Cmd err (Tree NodeTree)
  88 treeDB r nodeTypes = toTree =<< (toTreeParent <$> dbTree r nodeTypes)
  89
  90 type RootId = NodeId
  91 type ParentId = NodeId
  92 ------------------------------------------------------------------------
  93 toTree :: (MonadError e m, HasTreeError e)
  94        => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
  95 toTree m =
  96     case lookup Nothing m of
  97         Just [n] -> pure $ toTree' m n
  98         Nothing  -> treeError NoRoot
  99         Just []  -> treeError EmptyRoot
 100         Just _   -> treeError TooManyRoots
 101
 102 toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
 103 toTree' m n =
 104   TreeN (toNodeTree n) $
 105     m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
 106
 107 ------------------------------------------------------------------------
 108 toNodeTree :: DbTreeNode -> NodeTree
 109 toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
 110   where
 111     nodeType = fromNodeTypeId tId
 112 ------------------------------------------------------------------------
 113 toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
 114 toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
 115 ------------------------------------------------------------------------
 116 data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
 117                              , dt_typeId :: Int
 118                              , dt_parentId :: Maybe NodeId
 119                              , dt_name     :: Text
 120                              } deriving (Show)
 121
 122 -- | Main DB Tree function
 123 -- TODO add typenames as parameters
 124 dbTree :: RootId -> [NodeType] -> Cmd err [DbTreeNode]
 125 dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
 126   <$> runPGSQuery [sql|
 127     WITH RECURSIVE
 128         tree (id, typename, parent_id, name) AS
 129         (
 130           SELECT p.id, p.typename, p.parent_id, p.name
 131           FROM nodes AS p
 132           WHERE p.id = ?
 133
 134           UNION
 135
 136           SELECT c.id, c.typename, c.parent_id, c.name
 137           FROM nodes AS c
 138
 139           INNER JOIN tree AS s ON c.parent_id = s.id
 140            WHERE c.typename IN ?
 141         )
 142     SELECT * from tree;
 143     |] (rootId, In typename)
 144   where
 145     typename = map nodeTypeId ns
 146     ns = case nodeTypes of
 147       [] -> allNodeTypes
 148       -- [2, 20, 21, 22, 3, 5, 30, 31, 40, 7, 9, 90, 71]
 149       _  -> nodeTypes
 150
 151 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 152 isDescendantOf childId rootId = (== [Only True])
 153   <$> runPGSQuery [sql|
 154                   BEGIN ;
 155                   SET TRANSACTION READ ONLY;
 156                   COMMIT;
 157
 158                   WITH RECURSIVE
 159       tree (id, parent_id) AS
 160       (
 161         SELECT c.id, c.parent_id
 162         FROM nodes AS c
 163         WHERE c.id = ?
 164
 165         UNION
 166
 167         SELECT p.id, p.parent_id
 168         FROM nodes AS p
 169         INNER JOIN tree AS t ON t.parent_id = p.id
 170
 171       )
 172   SELECT COUNT(*) = 1 from tree AS t
 173   WHERE t.id = ?;
 174   |] (childId, rootId)
 175
 176 -- TODO should we check the category?
 177 isIn :: NodeId -> DocId -> Cmd err Bool
 178 isIn cId docId = ( == [Only True])
 179   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 180     FROM nodes_nodes nn
 181       WHERE nn.node1_id = ?
 182         AND nn.node2_id = ?;
 183   |] (cId, docId)
 184
 185