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