1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
{-|
Module : Gargantext.Database.Tree
Description : Tree of Resource Nodes built from Database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Let a Root Node, return the Tree of the Node as a directed acyclic graph
(Tree).
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Query.Tree
( module Gargantext.Database.Query.Tree.Error
, isDescendantOf
, isIn
, treeDB
)
where
import Control.Lens ((^..), at, each, _Just, to)
import Control.Monad.Error.Class (MonadError())
import Data.Map (Map, fromListWith, lookup)
import Data.Text (Text)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
import Gargantext.Database.Admin.Types.Node -- (pgNodeId, NodeType(..))
import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId)
import Gargantext.Database.Admin.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
import Gargantext.Database.Query.Tree.Error
import Gargantext.Prelude
------------------------------------------------------------------------
-- TODO more generic find fun
_findCorpus :: RootId -> Cmd err (Maybe CorpusId)
_findCorpus r = do
_mapNodes <- toTreeParent <$> dbTree r []
pure Nothing
-- | Returns the Tree of Nodes in Database
treeDB :: HasTreeError err
=> RootId
-> [NodeType]
-> Cmd err (Tree NodeTree)
treeDB r nodeTypes = toTree =<< (toTreeParent <$> dbTree r nodeTypes)
------------------------------------------------------------------------
toTree :: ( MonadError e m
, HasTreeError e)
=> Map (Maybe ParentId) [DbTreeNode]
-> m (Tree NodeTree)
toTree m =
case lookup Nothing m of
Just [n] -> pure $ toTree' m n
Nothing -> treeError NoRoot
Just [] -> treeError EmptyRoot
Just _ -> treeError TooManyRoots
toTree' :: Map (Maybe ParentId) [DbTreeNode]
-> DbTreeNode
-> Tree NodeTree
toTree' m n =
TreeN (toNodeTree n) $
m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
------------------------------------------------------------------------
toNodeTree :: DbTreeNode
-> NodeTree
toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
where
nodeType = fromNodeTypeId tId
------------------------------------------------------------------------
toTreeParent :: [DbTreeNode]
-> Map (Maybe ParentId) [DbTreeNode]
toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
------------------------------------------------------------------------
data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
, dt_typeId :: Int
, dt_parentId :: Maybe NodeId
, dt_name :: Text
} deriving (Show)
-- | Main DB Tree function
-- TODO add typenames as parameters
dbTree :: RootId
-> [NodeType]
-> Cmd err [DbTreeNode]
dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
<$> runPGSQuery [sql|
WITH RECURSIVE
tree (id, typename, parent_id, name) AS
(
SELECT p.id, p.typename, p.parent_id, p.name
FROM nodes AS p
WHERE p.id = ?
UNION
SELECT c.id, c.typename, c.parent_id, c.name
FROM nodes AS c
INNER JOIN tree AS s ON c.parent_id = s.id
WHERE c.typename IN ?
)
SELECT * from tree;
|] (rootId, In typename)
where
typename = map nodeTypeId ns
ns = case nodeTypes of
[] -> allNodeTypes
-- [2, 20, 21, 22, 3, 5, 30, 31, 40, 7, 9, 90, 71]
_ -> nodeTypes
isDescendantOf :: NodeId -> RootId -> Cmd err Bool
isDescendantOf childId rootId = (== [Only True])
<$> runPGSQuery [sql|
BEGIN ;
SET TRANSACTION READ ONLY;
COMMIT;
WITH RECURSIVE
tree (id, parent_id) AS
(
SELECT c.id, c.parent_id
FROM nodes AS c
WHERE c.id = ?
UNION
SELECT p.id, p.parent_id
FROM nodes AS p
INNER JOIN tree AS t ON t.parent_id = p.id
)
SELECT COUNT(*) = 1 from tree AS t
WHERE t.id = ?;
|] (childId, rootId)
-- TODO should we check the category?
isIn :: NodeId -> DocId -> Cmd err Bool
isIn cId docId = ( == [Only True])
<$> runPGSQuery [sql| SELECT COUNT(*) = 1
FROM nodes_nodes nn
WHERE nn.node1_id = ?
AND nn.node2_id = ?;
|] (cId, docId)