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 FlexibleContexts  #-}
  16 {-# LANGUAGE NoImplicitPrelude #-}
  17 {-# LANGUAGE QuasiQuotes       #-}
  18 {-# LANGUAGE RankNTypes        #-}
  19
  20 module Gargantext.Database.Tree
  21   ( treeDB
  22   , TreeError(..)
  23   , HasTreeError(..)
  24   , dbTree
  25   , toNodeTree
  26   , DbTreeNode
  27   , isDescendantOf
  28   , isIn
  29   ) where
  30
  31 import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
  32 import Control.Monad.Error.Class (MonadError(throwError))
  33 import Data.Map (Map, fromListWith, lookup)
  34 import Data.Text (Text)
  35 import Database.PostgreSQL.Simple
  36 import Database.PostgreSQL.Simple.SqlQQ
  37
  38 import Gargantext.Prelude
  39 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
  40 import Gargantext.Database.Config (fromNodeTypeId, nodeTypeId)
  41 import Gargantext.Database.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
  42 import Gargantext.Database.Utils (Cmd, runPGSQuery)
  43 ------------------------------------------------------------------------
  44 -- import Gargantext.Database.Utils (runCmdDev)
  45 -- treeTest :: IO (Tree NodeTree)
  46 -- treeTest = runCmdDev $ treeDB 347474
  47 ------------------------------------------------------------------------
  48
  49 data TreeError = NoRoot | EmptyRoot | TooManyRoots
  50   deriving (Show)
  51
  52 class HasTreeError e where
  53   _TreeError :: Prism' e TreeError
  54
  55 treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
  56 treeError te = throwError $ _TreeError # te
  57
  58 -- | Returns the Tree of Nodes in Database
  59 treeDB :: HasTreeError err => RootId -> [NodeType] -> Cmd err (Tree NodeTree)
  60 treeDB r nodeTypes = toTree =<< (toTreeParent <$> dbTree r nodeTypes)
  61
  62 type RootId = NodeId
  63 type ParentId = NodeId
  64 ------------------------------------------------------------------------
  65 toTree :: (MonadError e m, HasTreeError e)
  66        => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
  67 toTree m =
  68     case lookup Nothing m of
  69         Just [n] -> pure $ toTree' m n
  70         Nothing  -> treeError NoRoot
  71         Just []  -> treeError EmptyRoot
  72         Just _   -> treeError TooManyRoots
  73
  74 toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
  75 toTree' m n =
  76   TreeN (toNodeTree n) $
  77     m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
  78
  79 ------------------------------------------------------------------------
  80 toNodeTree :: DbTreeNode -> NodeTree
  81 toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
  82   where
  83     nodeType = fromNodeTypeId tId
  84 ------------------------------------------------------------------------
  85 toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
  86 toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
  87 ------------------------------------------------------------------------
  88 data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
  89                              , dt_typeId :: Int
  90                              , dt_parentId :: Maybe NodeId
  91                              , dt_name     :: Text
  92                              } deriving (Show)
  93
  94 -- | Main DB Tree function
  95 -- TODO add typenames as parameters
  96 dbTree :: RootId -> [NodeType] -> Cmd err [DbTreeNode]
  97 dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
  98   <$> runPGSQuery [sql|
  99     WITH RECURSIVE
 100         tree (id, typename, parent_id, name) AS
 101         (
 102           SELECT p.id, p.typename, p.parent_id, p.name
 103           FROM nodes AS p
 104           WHERE p.id = ?
 105
 106           UNION
 107
 108           SELECT c.id, c.typename, c.parent_id, c.name
 109           FROM nodes AS c
 110
 111           INNER JOIN tree AS s ON c.parent_id = s.id
 112            WHERE c.typename IN ?
 113         )
 114     SELECT * from tree;
 115     |] (rootId, In typename)
 116   where
 117     typename = map nodeTypeId ns
 118     ns = case nodeTypes of
 119       [] -> allNodeTypes
 120       -- [2, 20, 21, 22, 3, 5, 30, 31, 40, 7, 9, 90, 71]
 121       _  -> nodeTypes
 122
 123 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 124 isDescendantOf childId rootId = (== [Only True])
 125   <$> runPGSQuery [sql|
 126                   BEGIN ;
 127                   SET TRANSACTION READ ONLY;
 128                   COMMIT;
 129
 130                   WITH RECURSIVE
 131       tree (id, parent_id) AS
 132       (
 133         SELECT c.id, c.parent_id
 134         FROM nodes AS c
 135         WHERE c.id = ?
 136
 137         UNION
 138
 139         SELECT p.id, p.parent_id
 140         FROM nodes AS p
 141         INNER JOIN tree AS t ON t.parent_id = p.id
 142
 143       )
 144   SELECT COUNT(*) = 1 from tree AS t
 145   WHERE t.id = ?;
 146   |] (childId, rootId)
 147
 148 -- TODO should we check the category?
 149 isIn :: NodeId -> DocId -> Cmd err Bool
 150 isIn cId docId = ( == [Only True])
 151   <$> runPGSQuery [sql| SELECT COUNT(*) = 1
 152     FROM nodes_nodes nn
 153       WHERE nn.node1_id = ?
 154         AND nn.node2_id = ?;
 155   |] (cId, docId)
 156
 157