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 #-}
18 module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..)) where
20 import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
21 import Control.Monad.Error.Class (MonadError(throwError))
22 import Control.Monad.IO.Class (MonadIO(liftIO))
23 import Data.Map (Map, fromListWith, lookup)
24 import Data.Text (Text)
25 import Database.PostgreSQL.Simple
26 import Database.PostgreSQL.Simple.SqlQQ
28 import Gargantext.Prelude
29 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
30 import Gargantext.Database.Config (typeId2node)
31 ------------------------------------------------------------------------
32 -- import Gargantext (connectGargandb)
33 -- import Control.Monad ((>>=))
34 -- treeTest :: IO (Tree NodeTree)
35 -- treeTest = connectGargandb "gargantext.ini" >>= \c -> treeDB c 347474
36 ------------------------------------------------------------------------
38 data TreeError = NoRoot | EmptyRoot | TooManyRoots
41 class HasTreeError e where
42 _TreeError :: Prism' e TreeError
44 treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
45 treeError te = throwError $ _TreeError # te
47 -- | Returns the Tree of Nodes in Database
48 treeDB :: (MonadIO m, MonadError e m, HasTreeError e)
49 => Connection -> RootId -> m (Tree NodeTree)
50 treeDB c r = toTree =<< (toTreeParent <$> liftIO (dbTree c r))
54 ------------------------------------------------------------------------
55 toTree :: (MonadError e m, HasTreeError e)
56 => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
58 case lookup Nothing m of
59 Just [n] -> pure $ toTree' m n
60 Nothing -> treeError NoRoot
61 Just [] -> treeError EmptyRoot
62 Just _ -> treeError TooManyRoots
64 toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
66 TreeN (toNodeTree n) $
67 m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
70 ------------------------------------------------------------------------
71 toNodeTree :: DbTreeNode -> NodeTree
72 toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
74 nodeType = typeId2node tId
75 ------------------------------------------------------------------------
76 toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
77 toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
78 ------------------------------------------------------------------------
79 data DbTreeNode = DbTreeNode { dt_nodeId :: Int
81 , dt_parentId :: Maybe Int
86 dbTree :: Connection -> RootId -> IO [DbTreeNode]
87 dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> query conn [sql|
90 starting (id, typename, parent_id, name) AS
92 SELECT n.id, n.typename, n.parent_id, n.name
94 WHERE n.parent_id = ? -- this can be arbitrary
96 descendants (id, typename, parent_id, name) AS
98 SELECT id, typename, parent_id, name
101 SELECT n.id, n.typename, n.parent_id, n.name
102 FROM nodes AS n JOIN descendants AS d ON n.parent_id = d.id
103 where n.typename in (2,3,31)
105 ancestors (id, typename, parent_id, name) AS
107 SELECT n.id, n.typename, n.parent_id, n.name
109 WHERE n.id IN (SELECT parent_id FROM starting)
111 SELECT n.id, n.typename, n.parent_id, n.name
112 FROM nodes AS n JOIN ancestors AS a ON n.id = a.parent_id