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
  18 module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..)) where
  19
  20 import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
  21 import Control.Monad.Error.Class (MonadError(throwError))
  22 import Control.Monad.IO.Class (MonadIO(liftIO))
  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 ------------------------------------------------------------------------
  32 -- import Gargantext (connectGargandb)
  33 -- import Control.Monad ((>>=))
  34 -- treeTest :: IO (Tree NodeTree)
  35 -- treeTest = connectGargandb "gargantext.ini" >>= \c -> treeDB c 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 :: (MonadIO m, MonadError e m, HasTreeError e)
  49        => Connection -> RootId -> m (Tree NodeTree)
  50 treeDB c r = toTree =<< (toTreeParent <$> liftIO (dbTree c r))
  51
  52 type RootId = Int
  53 type ParentId = Int
  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 :: Int
  79                              , dt_typeId :: Int
  80                              , dt_parentId :: Maybe Int
  81                              , dt_name     :: Text
  82                              } deriving (Show)
  83
  84
  85 dbTree :: Connection -> RootId -> IO [DbTreeNode]
  86 dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> query conn [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)
 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