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
10 Let a Root Node, return the Tree of the Node as a directed acyclic graph
15 {-# LANGUAGE NoImplicitPrelude #-}
16 {-# LANGUAGE QuasiQuotes #-}
17 {-# LANGUAGE RankNTypes #-}
19 module Gargantext.Database.Tree
30 import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
31 import Control.Monad.Error.Class (MonadError(throwError))
32 import Data.Map (Map, fromListWith, lookup)
33 import Data.Text (Text)
34 import Database.PostgreSQL.Simple
35 import Database.PostgreSQL.Simple.SqlQQ
37 import Gargantext.Prelude
38 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
39 import Gargantext.Database.Types.Node (NodeId, DocId)
40 import Gargantext.Database.Config (fromNodeTypeId)
41 import Gargantext.Database.Utils (Cmd, runPGSQuery)
42 ------------------------------------------------------------------------
43 -- import Gargantext.Database.Utils (runCmdDev)
44 -- treeTest :: IO (Tree NodeTree)
45 -- treeTest = runCmdDev $ treeDB 347474
46 ------------------------------------------------------------------------
48 data TreeError = NoRoot | EmptyRoot | TooManyRoots
51 class HasTreeError e where
52 _TreeError :: Prism' e TreeError
54 treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
55 treeError te = throwError $ _TreeError # te
57 -- | Returns the Tree of Nodes in Database
58 treeDB :: HasTreeError err => RootId -> Cmd err (Tree NodeTree)
59 treeDB r = toTree =<< (toTreeParent <$> dbTree r)
62 type ParentId = NodeId
63 ------------------------------------------------------------------------
64 toTree :: (MonadError e m, HasTreeError e)
65 => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
67 case lookup Nothing m of
68 Just [n] -> pure $ toTree' m n
69 Nothing -> treeError NoRoot
70 Just [] -> treeError EmptyRoot
71 Just _ -> treeError TooManyRoots
73 toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
75 TreeN (toNodeTree n) $
76 m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
78 ------------------------------------------------------------------------
79 toNodeTree :: DbTreeNode -> NodeTree
80 toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
82 nodeType = fromNodeTypeId tId
83 ------------------------------------------------------------------------
84 toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
85 toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
86 ------------------------------------------------------------------------
87 data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
89 , dt_parentId :: Maybe NodeId
93 -- | Main DB Tree function
94 -- TODO add typenames as parameters
95 dbTree :: RootId -> Cmd err [DbTreeNode]
96 dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
99 tree (id, typename, parent_id, name) AS
101 SELECT p.id, p.typename, p.parent_id, p.name
107 SELECT c.id, c.typename, c.parent_id, c.name
110 INNER JOIN tree AS s ON c.parent_id = s.id
111 -- WHERE c.typename IN (2,20,21,22,3,5,30,31,40,7,9,90)
116 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
117 isDescendantOf childId rootId = (== [Only True])
118 <$> runPGSQuery [sql| WITH RECURSIVE
119 tree (id, parent_id) AS
121 SELECT c.id, c.parent_id
127 SELECT p.id, p.parent_id
129 INNER JOIN tree AS t ON t.parent_id = p.id
132 SELECT COUNT(*) = 1 from tree AS t
136 -- TODO should we check the category?
137 isIn :: NodeId -> DocId -> Cmd err Bool
138 isIn cId docId = ( == [Only True])
139 <$> runPGSQuery [sql| SELECT COUNT(*) = 1
141 WHERE nn.node1_id = ?