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 (treeDB, TreeError(..), HasTreeError(..), dbTree, toNodeTree, DbTreeNode) where
  20
  21 import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
  22 import Control.Monad.Error.Class (MonadError(throwError))
  23 import Data.Map (Map, fromListWith, lookup)
  24 import Data.Text (Text)
  25 import Database.PostgreSQL.Simple
  26 import Database.PostgreSQL.Simple.SqlQQ
  27
  28 import Gargantext.Prelude
  29 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
  30 import Gargantext.Database.Config (fromNodeTypeId)
  31 import Gargantext.Database.Utils (Cmd, runPGSQuery)
  32 ------------------------------------------------------------------------
  33 -- import Gargantext.Database.Utils (runCmdDev)
  34 -- treeTest :: IO (Tree NodeTree)
  35 -- treeTest = runCmdDev $ treeDB 347474
  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, HasTreeError e) => TreeError -> m a
  45 treeError te = throwError $ _TreeError # te
  46
  47 -- | Returns the Tree of Nodes in Database
  48 treeDB :: HasTreeError err => RootId -> Cmd err (Tree NodeTree)
  49 treeDB r = toTree =<< (toTreeParent <$> dbTree r)
  50
  51 type RootId = Int
  52 type ParentId = Int
  53 ------------------------------------------------------------------------
  54 toTree :: (MonadError e m, HasTreeError e)
  55        => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
  56 toTree m =
  57     case lookup Nothing m of
  58         Just [n] -> pure $ toTree' m n
  59         Nothing  -> treeError NoRoot
  60         Just []  -> treeError EmptyRoot
  61         Just _   -> treeError TooManyRoots
  62
  63 toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
  64 toTree' m n =
  65   TreeN (toNodeTree n) $
  66     m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
  67
  68 ------------------------------------------------------------------------
  69 toNodeTree :: DbTreeNode -> NodeTree
  70 toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
  71   where
  72     nodeType = fromNodeTypeId tId
  73 ------------------------------------------------------------------------
  74 toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
  75 toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
  76 ------------------------------------------------------------------------
  77 data DbTreeNode = DbTreeNode { dt_nodeId :: Int
  78                              , dt_typeId :: Int
  79                              , dt_parentId :: Maybe Int
  80                              , dt_name     :: Text
  81                              } deriving (Show)
  82
  83 -- | Main DB Tree function
  84 -- TODO add typenames as parameters
  85 dbTree :: RootId -> Cmd err [DbTreeNode]
  86 dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGSQuery [sql|
  87   WITH RECURSIVE
  88       -- starting node(s)
  89       starting (id, typename, parent_id, name) AS
  90       (
  91         SELECT n.id, n.typename, n.parent_id, n.name
  92         FROM nodes AS n
  93         WHERE n.parent_id = ?           -- this can be arbitrary
  94       ),
  95       descendants (id, typename, parent_id, name) AS
  96       (
  97         SELECT id, typename, parent_id, name
  98         FROM starting
  99         UNION ALL
 100         SELECT n.id, n.typename, n.parent_id, n.name
 101         FROM nodes AS n JOIN descendants AS d ON n.parent_id = d.id
 102         where n.typename in (2,3,30,31,5,7,9)
 103       ),
 104       ancestors (id, typename, parent_id, name) AS
 105       (
 106         SELECT n.id, n.typename, n.parent_id, n.name
 107         FROM nodes AS n
 108         WHERE n.id IN (SELECT parent_id FROM starting)
 109         UNION ALL
 110         SELECT n.id, n.typename, n.parent_id, n.name
 111         FROM nodes AS n JOIN ancestors AS a ON n.id = a.parent_id
 112       )
 113   TABLE ancestors
 114   UNION ALL
 115   TABLE descendants ;
 116   |] (Only rootId)
 117