src/Gargantext/Database/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 NoImplicitPrelude #-}
  16 {-# LANGUAGE QuasiQuotes       #-}
  17 {-# LANGUAGE RankNTypes        #-}
  18
  19 module Gargantext.Database.Tree
  20   ( treeDB
  21   , TreeError(..)
  22   , HasTreeError(..)
  23   , dbTree
  24   , toNodeTree
  25   , DbTreeNode
  26   , isDescendantOf
  27   ) where
  28
  29 import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
  30 import Control.Monad.Error.Class (MonadError(throwError))
  31 import Data.Map (Map, fromListWith, lookup)
  32 import Data.Text (Text)
  33 import Database.PostgreSQL.Simple
  34 import Database.PostgreSQL.Simple.SqlQQ
  35
  36 import Gargantext.Prelude
  37 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
  38 import Gargantext.Database.Types.Node (NodeId)
  39 import Gargantext.Database.Config (fromNodeTypeId)
  40 import Gargantext.Database.Utils (Cmd, runPGSQuery)
  41 ------------------------------------------------------------------------
  42 -- import Gargantext.Database.Utils (runCmdDev)
  43 -- treeTest :: IO (Tree NodeTree)
  44 -- treeTest = runCmdDev $ treeDB 347474
  45 ------------------------------------------------------------------------
  46
  47 data TreeError = NoRoot | EmptyRoot | TooManyRoots
  48   deriving (Show)
  49
  50 class HasTreeError e where
  51   _TreeError :: Prism' e TreeError
  52
  53 treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
  54 treeError te = throwError $ _TreeError # te
  55
  56 -- | Returns the Tree of Nodes in Database
  57 treeDB :: HasTreeError err => RootId -> Cmd err (Tree NodeTree)
  58 treeDB r = toTree =<< (toTreeParent <$> dbTree r)
  59
  60 type RootId = NodeId
  61 type ParentId = NodeId
  62 ------------------------------------------------------------------------
  63 toTree :: (MonadError e m, HasTreeError e)
  64        => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
  65 toTree m =
  66     case lookup Nothing m of
  67         Just [n] -> pure $ toTree' m n
  68         Nothing  -> treeError NoRoot
  69         Just []  -> treeError EmptyRoot
  70         Just _   -> treeError TooManyRoots
  71
  72 toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
  73 toTree' m n =
  74   TreeN (toNodeTree n) $
  75     m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
  76
  77 ------------------------------------------------------------------------
  78 toNodeTree :: DbTreeNode -> NodeTree
  79 toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
  80   where
  81     nodeType = fromNodeTypeId tId
  82 ------------------------------------------------------------------------
  83 toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
  84 toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
  85 ------------------------------------------------------------------------
  86 data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
  87                              , dt_typeId :: Int
  88                              , dt_parentId :: Maybe NodeId
  89                              , dt_name     :: Text
  90                              } deriving (Show)
  91
  92 -- | Main DB Tree function
  93 -- TODO add typenames as parameters
  94 dbTree :: RootId -> Cmd err [DbTreeNode]
  95 dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGSQuery [sql|
  96   WITH RECURSIVE
  97       tree (id, typename, parent_id, name) AS
  98       (
  99         SELECT p.id, p.typename, p.parent_id, p.name
 100         FROM nodes AS p
 101         WHERE p.id = ?
 102
 103         UNION
 104
 105         SELECT c.id, c.typename, c.parent_id, c.name
 106         FROM nodes AS c
 107
 108         INNER JOIN tree AS s ON c.parent_id = s.id
 109         WHERE c.typename IN (2,20,21,22,3,5,30,31,40,7,9,90)
 110       )
 111   SELECT * from tree;
 112   |] (Only rootId)
 113
 114 isDescendantOf :: NodeId -> RootId -> Cmd err Bool
 115 isDescendantOf childId rootId = (== [Only True]) <$> runPGSQuery [sql|
 116   WITH RECURSIVE
 117       tree (id, parent_id) AS
 118       (
 119         SELECT c.id, c.parent_id
 120         FROM nodes AS c
 121         WHERE c.id = ?
 122
 123         UNION
 124
 125         SELECT p.id, p.parent_id
 126         FROM nodes AS p
 127         INNER JOIN tree AS t ON t.parent_id = p.id
 128       )
 129   SELECT COUNT(*) = 1 from tree AS t
 130   WHERE t.id = ?;
 131   |] (childId, rootId)