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.Config (fromNodeTypeId, nodeTypeId)
  40 import Gargantext.Database.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
  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 -> [NodeType] -> Cmd err (Tree NodeTree)
  59 treeDB r nodeTypes = toTree =<< (toTreeParent <$> dbTree r nodeTypes)
  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 -> [NodeType] -> Cmd err [DbTreeNode]
  96 dbTree rootId nodeTypes = 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 ?
 112         )
 113     SELECT * from tree;
 114     |] (rootId, In typename)
 115   where
 116     typename = map nodeTypeId ns
 117     ns = case nodeTypes of
 118       [] -> allNodeTypes
 119       -- [2, 20, 21, 22, 3, 5, 30, 31, 40, 7, 9, 90, 71]
 120       _  -> nodeTypes
 121
 122 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 123 isDescendantOf childId rootId = (== [Only True])
 124   <$> runPGSQuery [sql| WITH RECURSIVE
 125       tree (id, parent_id) AS
 126       (
 127         SELECT c.id, c.parent_id
 128         FROM nodes AS c
 129         WHERE c.id = ?
 130
 131         UNION
 132
 133         SELECT p.id, p.parent_id
 134         FROM nodes AS p
 135         INNER JOIN tree AS t ON t.parent_id = p.id
 136
 137       )
 138   SELECT COUNT(*) = 1 from tree AS t
 139   WHERE t.id = ?;
 140   |] (childId, rootId)
 141
 142 -- TODO should we check the category?
 143 isIn :: NodeId -> DocId -> Cmd err Bool
 144 isIn cId docId = ( == [Only True])
 145   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 146     FROM nodes_nodes nn
 147       WHERE nn.node1_id = ?
 148         AND nn.node2_id = ?;
 149   |] (cId, docId)
 150
 151