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