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