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