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       tree (id, typename, parent_id, name) AS
  90       (
  91         SELECT p.id, p.typename, p.parent_id, p.name
  92         FROM nodes AS p
  93         WHERE p.id = ?
  94
  95         UNION
  96
  97         SELECT c.id, c.typename, c.parent_id, c.name
  98         FROM nodes AS c
  99
 100         INNER JOIN tree AS s ON c.parent_id = s.id
 101         WHERE c.typename IN (2,3,5,30,31,40,7,9,90)
 102       )
 103   SELECT * from tree;
 104   |] (Only rootId)
 105
 106
 107
 108
 109