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