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