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