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