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