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