src/Gargantext/API/GraphQL/TreeFirstLevel.hs

   1 {-# LANGUAGE DeriveAnyClass #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3
   4 module Gargantext.API.GraphQL.TreeFirstLevel where
   5
   6 import Gargantext.Prelude
   7 import Data.Morpheus.Types (GQLType, lift, Resolver, QUERY)
   8 import GHC.Generics (Generic)
   9 import Data.Text (Text)
  10 import Gargantext.API.Prelude (GargM, GargError)
  11 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
  12 import Gargantext.Core.Mail.Types (HasMail)
  13 import qualified Gargantext.Database.Query.Tree as T
  14 import qualified Gargantext.Database.Schema.Node as N
  15 import qualified Gargantext.Database.Admin.Types.Node as NN
  16 import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId (NodeId))
  17 import Gargantext.Core.Types (Tree, NodeTree, NodeType)
  18 import Gargantext.Core.Types.Main
  19     ( Tree(TreeN), _tn_node, _tn_children, NodeTree(NodeTree, _nt_id, _nt_type), _nt_name )
  20 import Gargantext.Database.Query.Table.Node (getNode)
  21 import Gargantext.Database.Admin.Config (fromNodeTypeId)
  22 import Gargantext.Database.Schema.Node (NodePoly(_node_parent_id))
  23
  24 data TreeArgs = TreeArgs
  25   {
  26     root_id :: Int
  27   } deriving (Generic, GQLType)
  28
  29 data TreeNode = TreeNode
  30   {
  31     name      :: Text
  32   , id        :: Int
  33   , node_type :: NodeType
  34   } deriving (Generic, GQLType)
  35
  36 data TreeFirstLevel m = TreeFirstLevel
  37   {
  38     root     :: TreeNode
  39   , parent   :: m (Maybe TreeNode)
  40   , children :: [TreeNode]
  41   } deriving (Generic, GQLType)
  42
  43 type GqlM e env = Resolver QUERY e (GargM env GargError)
  44
  45 resolveTree :: (HasConnectionPool env, HasConfig env, HasMail env) => TreeArgs -> GqlM e env (TreeFirstLevel (GqlM e env))
  46 resolveTree TreeArgs { root_id } = dbTree root_id
  47
  48 dbTree :: (HasConnectionPool env, HasConfig env, HasMail env) => Int -> GqlM e env (TreeFirstLevel (GqlM e env))
  49 dbTree root_id = do
  50   t <- lift $ T.tree T.TreeFirstLevel (NodeId root_id) allNodeTypes
  51   n <- lift $ getNode $ NodeId root_id
  52   let pId = toParentId n
  53   pure $ toTree pId t
  54   where
  55     toParentId N.Node { _node_parent_id } = _node_parent_id
  56
  57
  58 toTree :: (HasConnectionPool env, HasConfig env, HasMail env) => Maybe NodeId -> Tree NodeTree -> TreeFirstLevel (GqlM e env)
  59 toTree pId TreeN { _tn_node, _tn_children } = TreeFirstLevel
  60   { parent   = resolveParent pId
  61   , root     = toTreeNode _tn_node
  62   , children = map childrenToTreeNodes _tn_children
  63   }
  64
  65 toTreeNode :: NodeTree -> TreeNode
  66 toTreeNode NodeTree { _nt_name, _nt_id, _nt_type } = TreeNode { name = _nt_name, id = id2int _nt_id, node_type = _nt_type }
  67   where
  68     id2int :: NodeId -> Int
  69     id2int (NodeId n) = n
  70
  71 childrenToTreeNodes :: Tree NodeTree -> TreeNode
  72 childrenToTreeNodes TreeN {_tn_node} = toTreeNode _tn_node
  73
  74 resolveParent :: (HasConnectionPool env, HasConfig env, HasMail env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
  75 resolveParent (Just pId) = do
  76   node <- lift $ getNode pId
  77   pure $ Just $ nodeToTreeNode node
  78 resolveParent Nothing = pure Nothing
  79
  80
  81 nodeToTreeNode :: NN.Node json -> TreeNode
  82 nodeToTreeNode N.Node {..} = TreeNode { id        = NN.unNodeId _node_id
  83                                       , name      = _node_name
  84                                       , node_type = fromNodeTypeId _node_typename
  85                                       }