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|
 125                   BEGIN ;
 126                   SET TRANSACTION READ ONLY;
 127                   COMMIT;
 128
 129                   WITH RECURSIVE
 130       tree (id, parent_id) AS
 131       (
 132         SELECT c.id, c.parent_id
 133         FROM nodes AS c
 134         WHERE c.id = ?
 135
 136         UNION
 137
 138         SELECT p.id, p.parent_id
 139         FROM nodes AS p
 140         INNER JOIN tree AS t ON t.parent_id = p.id
 141
 142       )
 143   SELECT COUNT(*) = 1 from tree AS t
 144   WHERE t.id = ?;
 145   |] (childId, rootId)
 146
 147 -- TODO should we check the category?
 148 isIn :: NodeId -> DocId -> Cmd err Bool
 149 isIn cId docId = ( == [Only True])
 150   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 151     FROM nodes_nodes nn
 152       WHERE nn.node1_id = ?
 153         AND nn.node2_id = ?;
 154   |] (cId, docId)
 155
 156