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 (typeId2node)
  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 ------------------------------------------------------------------------
  71 toNodeTree :: DbTreeNode -> NodeTree
  72 toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
  73   where
  74     nodeType = typeId2node tId
  75 ------------------------------------------------------------------------
  76 toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
  77 toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
  78 ------------------------------------------------------------------------
  79 data DbTreeNode = DbTreeNode { dt_nodeId :: Int
  80                              , dt_typeId :: Int
  81                              , dt_parentId :: Maybe Int
  82                              , dt_name     :: Text
  83                              } deriving (Show)
  84
  85
  86 dbTree :: Connection -> RootId -> IO [DbTreeNode]
  87 dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> query conn [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,30,31)
 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