]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Tree.hs
changement du seuil
[gargantext.git] / src / Gargantext / Database / 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 NoImplicitPrelude #-}
16 {-# LANGUAGE QuasiQuotes #-}
17 {-# LANGUAGE RankNTypes #-}
18
19 module Gargantext.Database.Tree
20 ( treeDB
21 , TreeError(..)
22 , HasTreeError(..)
23 , dbTree
24 , toNodeTree
25 , DbTreeNode
26 , isDescendantOf
27 , isIn
28 ) where
29
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
36
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 ------------------------------------------------------------------------
47
48 data TreeError = NoRoot | EmptyRoot | TooManyRoots
49 deriving (Show)
50
51 class HasTreeError e where
52 _TreeError :: Prism' e TreeError
53
54 treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
55 treeError te = throwError $ _TreeError # te
56
57 -- | Returns the Tree of Nodes in Database
58 treeDB :: HasTreeError err => RootId -> Cmd err (Tree NodeTree)
59 treeDB r = toTree =<< (toTreeParent <$> dbTree r)
60
61 type RootId = NodeId
62 type ParentId = NodeId
63 ------------------------------------------------------------------------
64 toTree :: (MonadError e m, HasTreeError e)
65 => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
66 toTree m =
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
72
73 toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
74 toTree' m n =
75 TreeN (toNodeTree n) $
76 m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
77
78 ------------------------------------------------------------------------
79 toNodeTree :: DbTreeNode -> NodeTree
80 toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
81 where
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
88 , dt_typeId :: Int
89 , dt_parentId :: Maybe NodeId
90 , dt_name :: Text
91 } deriving (Show)
92
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)
97 <$> runPGSQuery [sql|
98 WITH RECURSIVE
99 tree (id, typename, parent_id, name) AS
100 (
101 SELECT p.id, p.typename, p.parent_id, p.name
102 FROM nodes AS p
103 WHERE p.id = ?
104
105 UNION
106
107 SELECT c.id, c.typename, c.parent_id, c.name
108 FROM nodes AS c
109
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,71)
112 )
113 SELECT * from tree;
114 |] (Only rootId)
115
116 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
117 isDescendantOf childId rootId = (== [Only True])
118 <$> runPGSQuery [sql| WITH RECURSIVE
119 tree (id, parent_id) AS
120 (
121 SELECT c.id, c.parent_id
122 FROM nodes AS c
123 WHERE c.id = ?
124
125 UNION
126
127 SELECT p.id, p.parent_id
128 FROM nodes AS p
129 INNER JOIN tree AS t ON t.parent_id = p.id
130
131 )
132 SELECT COUNT(*) = 1 from tree AS t
133 WHERE t.id = ?;
134 |] (childId, rootId)
135
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
140 FROM nodes_nodes nn
141 WHERE nn.node1_id = ?
142 AND nn.node2_id = ?;
143 |] (cId, docId)
144
145