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
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Gargantext.API.GraphQL.TreeFirstLevel where
import Gargantext.Prelude
import Data.Morpheus.Types (GQLType, lift, Resolver, QUERY)
import GHC.Generics (Generic)
import Data.Text (Text)
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
import Gargantext.Core.Mail.Types (HasMail)
import qualified Gargantext.Database.Query.Tree as T
import qualified Gargantext.Database.Schema.Node as N
import qualified Gargantext.Database.Admin.Types.Node as NN
import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId (NodeId))
import Gargantext.Core.Types (Tree, NodeTree, NodeType)
import Gargantext.Core.Types.Main
( Tree(TreeN), _tn_node, _tn_children, NodeTree(NodeTree, _nt_id, _nt_type), _nt_name )
import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Admin.Config (fromNodeTypeId)
import Gargantext.Database.Schema.Node (NodePoly(_node_parent_id))
data TreeArgs = TreeArgs
{
root_id :: Int
} deriving (Generic, GQLType)
data TreeNode = TreeNode
{
name :: Text
, id :: Int
, node_type :: NodeType
, parent_id :: Maybe Int
} deriving (Generic, GQLType)
data TreeFirstLevel m = TreeFirstLevel
{
root :: TreeNode
, parent :: m (Maybe TreeNode)
, children :: [TreeNode]
} deriving (Generic, GQLType)
type GqlM e env = Resolver QUERY e (GargM env GargError)
type ParentId = Maybe NodeId
resolveTree :: (HasConnectionPool env, HasConfig env, HasMail env) => TreeArgs -> GqlM e env (TreeFirstLevel (GqlM e env))
resolveTree TreeArgs { root_id } = dbTree root_id
dbTree :: (HasConnectionPool env, HasConfig env, HasMail env) => Int -> GqlM e env (TreeFirstLevel (GqlM e env))
dbTree root_id = do
let rId = NodeId root_id
t <- lift $ T.tree T.TreeFirstLevel rId allNodeTypes
n <- lift $ getNode $ NodeId root_id
let pId = toParentId n
pure $ toTree rId pId t
where
toParentId N.Node { _node_parent_id } = _node_parent_id
toTree :: (HasConnectionPool env, HasConfig env, HasMail env) => NodeId -> ParentId -> Tree NodeTree -> TreeFirstLevel (GqlM e env)
toTree rId pId TreeN { _tn_node, _tn_children } = TreeFirstLevel
{ parent = resolveParent pId
, root = toTreeNode pId _tn_node
, children = map childrenToTreeNodes $ zip _tn_children $ repeat rId
}
toTreeNode :: ParentId -> NodeTree -> TreeNode
toTreeNode pId NodeTree { _nt_name, _nt_id, _nt_type } = TreeNode { name = _nt_name, id = id2int _nt_id, node_type = _nt_type, parent_id = id2int <$> pId}
where
id2int :: NodeId -> Int
id2int (NodeId n) = n
childrenToTreeNodes :: (Tree NodeTree, NodeId) -> TreeNode
childrenToTreeNodes (TreeN {_tn_node}, rId) = toTreeNode (Just rId) _tn_node
resolveParent :: (HasConnectionPool env, HasConfig env, HasMail env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
resolveParent (Just pId) = do
node <- lift $ getNode pId
pure $ Just $ nodeToTreeNode node
resolveParent Nothing = pure Nothing
nodeToTreeNode :: NN.Node json -> TreeNode
nodeToTreeNode N.Node {..} = TreeNode { id = NN.unNodeId _node_id
, name = _node_name
, node_type = fromNodeTypeId _node_typename
, parent_id = NN.unNodeId <$> _node_parent_id
}