[REFACT/CLEAN] TextFlow
[gargantext.git] / src / Gargantext / Database / Query / Tree.hs
index 0b599db69ae9a3c46433ecc2b8b7b4d76893759e..6161e84e142f8b758ad2579aed434ae5a6b74e88 100644 (file)
@@ -10,6 +10,8 @@ Portability : POSIX
 Let a Root Node, return the Tree of the Node as a directed acyclic graph
 (Tree).
 
+-- TODO delete node, if not owned, then suppress the link only
+-- see Action/Delete.hs
 -}
 
 {-# LANGUAGE QuasiQuotes       #-}
@@ -19,76 +21,206 @@ module Gargantext.Database.Query.Tree
   ( module Gargantext.Database.Query.Tree.Error
   , isDescendantOf
   , isIn
-  , treeDB
-  , treeDB'
+  , tree
+  , TreeMode(..)
   , findNodesId
   , DbTreeNode(..)
   , dt_name
   , dt_nodeId
   , dt_typeId
-  , shareNodeWith
   , findShared
+  , findNodes
+  , findNodesWithType
+  , NodeMode(..)
+
+  , sharedTreeUpdate
+  , dbTree
+  , updateTree
   )
   where
 
-import Control.Lens ((^..), at, each, _Just, to, set, makeLenses)
+import Control.Lens (view, toListOf, at, each, _Just, to, set, makeLenses)
 import Control.Monad.Error.Class (MonadError())
-import Data.List (tail, concat)
+import Data.List (tail, concat, nub)
+import qualified Data.List as List
 import Data.Map (Map, fromListWith, lookup)
+-- import Data.Monoid (mconcat)
+import Data.Proxy
+-- import qualified Data.Set  as Set
 import Data.Text (Text)
 import Database.PostgreSQL.Simple
 import Database.PostgreSQL.Simple.SqlQQ
+
+import Gargantext.Prelude
+import Gargantext.Core
 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
-import Gargantext.Core.Types.Individu (User(..))
-import Gargantext.Database.Admin.Types.Node -- (pgNodeId, NodeType(..))
-import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId)
-import Gargantext.Database.Admin.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
+import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId, fromNodeTypeId)
+import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny)
+import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (Cmd, runPGSQuery)
+import Gargantext.Database.Query.Table.Node (getNodeWith)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Query.Table.NodeNode (getNodeNode)
 import Gargantext.Database.Query.Tree.Error
-import Gargantext.Prelude
-
-import Gargantext.Database.Query.Tree.Root (getRoot)
-import Gargantext.Database.Query.Table.NodeNode (insertNodeNode, getNodeNode)
+import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Database.Schema.NodeNode (NodeNodePoly(..))
 
-import Gargantext.Database.Schema.Node
-
 ------------------------------------------------------------------------
-data DbTreeNode = DbTreeNode { _dt_nodeId :: NodeId
-                             , _dt_typeId :: Int
+data DbTreeNode = DbTreeNode { _dt_nodeId   :: NodeId
+                             , _dt_typeId   :: Int
                              , _dt_parentId :: Maybe NodeId
                              , _dt_name     :: Text
                              } deriving (Show)
 
 makeLenses ''DbTreeNode
+
+instance Eq DbTreeNode where
+  (==) d1 d2 = (==) (_dt_nodeId d1) (_dt_nodeId d2)
+
+------------------------------------------------------------------------
+
+data TreeMode = TreeBasic | TreeAdvanced | TreeFirstLevel
+
+-- | Returns the Tree of Nodes in Database
+tree :: (HasTreeError err, HasNodeError err)
+     => TreeMode
+     -> RootId
+     -> [NodeType]
+     -> Cmd err (Tree NodeTree)
+tree TreeBasic    = tree_basic
+tree TreeAdvanced = tree_advanced
+tree TreeFirstLevel = tree_first_level
+
+-- | Tree basic returns the Tree of Nodes in Database
+-- (without shared folders)
+-- keeping this for teaching purpose only
+tree_basic :: (HasTreeError err, HasNodeError err)
+
+           => RootId
+           -> [NodeType]
+           -> Cmd err (Tree NodeTree)
+tree_basic r nodeTypes =
+  (dbTree r nodeTypes <&> toTreeParent) >>= toTree
+  -- Same as (but easier to read) :
+  -- toTree =<< (toTreeParent <$> dbTree r nodeTypes)
+
+-- | Advanced mode of the Tree enables shared nodes
+tree_advanced :: (HasTreeError err, HasNodeError err)
+              => RootId
+              -> [NodeType]
+              -> Cmd err (Tree NodeTree)
+tree_advanced r nodeTypes = do
+  -- let rPrefix s = "[tree_advanced] root = " <> show r <> " " <> s
+  mainRoot    <- findNodes r Private nodeTypes
+  -- printDebug (rPrefix "mainRoot") mainRoot
+  publicRoots <- findNodes r Public  nodeTypes
+  -- printDebug (rPrefix "publicRoots") publicRoots
+  sharedRoots <- findNodes r Shared  nodeTypes
+  -- printDebug (rPrefix "sharedRoots") sharedRoots
+  toTree      $ toTreeParent (mainRoot <> sharedRoots <> publicRoots)
+
+-- | Fetch only first level of tree
+tree_first_level :: (HasTreeError err, HasNodeError err)
+                 => RootId
+                 -> [NodeType]
+                 -> Cmd err (Tree NodeTree)
+tree_first_level r nodeTypes = do
+  -- let rPrefix s = mconcat [ "[tree_first_level] root = "
+  --                         , show r
+  --                         , ", nodeTypes = "
+  --                         , show nodeTypes
+  --                         , " "
+  --                         , s ]
+  mainRoot    <- findNodes r Private nodeTypes
+  -- printDebug (rPrefix "mainRoot") mainRoot
+  publicRoots <- findNodes r Public  nodeTypes
+  -- printDebug (rPrefix "publicRoots") publicRoots
+  sharedRoots <- findNodes r SharedDirect  nodeTypes
+  -- printDebug (rPrefix "sharedRoots") sharedRoots
+  ret <- toTree $ toSubtreeParent r (mainRoot <> sharedRoots <> publicRoots)
+  -- printDebug (rPrefix "tree") ret
+  pure ret
+
+------------------------------------------------------------------------
+data NodeMode = Private | Shared | Public | SharedDirect
+
+findNodes :: (HasTreeError err, HasNodeError err)
+          => RootId
+          -> NodeMode
+          -> [NodeType]
+          -> Cmd err [DbTreeNode]
+findNodes r Private nt       = dbTree r nt
+findNodes r Shared  nt       = findShared r NodeFolderShared nt sharedTreeUpdate
+findNodes r SharedDirect  nt = findSharedDirect r NodeFolderShared nt sharedTreeUpdate
+findNodes r Public  nt       = findShared r NodeFolderPublic nt publicTreeUpdate
+
 ------------------------------------------------------------------------
 -- | Collaborative Nodes in the Tree
-findShared :: RootId -> [NodeType] -> Cmd err [DbTreeNode]
-findShared r nt = do
-  folderSharedId <- maybe (panic "no folder found") identity
-                <$> head
-                <$> findNodesId r [NodeFolderShared]
-  folders <- getNodeNode folderSharedId
-  nodesSharedId <- mapM (\child -> sharedTree folderSharedId child nt)
-                   $ map _nn_node2_id folders
+--   Queries the `nodes_nodes` table.
+findShared :: HasTreeError err
+           => RootId -> NodeType -> [NodeType] -> UpdateTree err
+           -> Cmd err [DbTreeNode]
+findShared r nt nts fun = do
+  foldersSharedId <- findNodesId r [nt]
+  trees           <- mapM (updateTree nts fun) foldersSharedId
+  pure $ concat trees
+
+-- | Find shared folders with "direct" access, i.e. when fetching only
+-- first-level subcomponents. This works in a simplified manner: fetch the node
+-- and get the tree for its parent.
+findSharedDirect :: (HasTreeError err, HasNodeError err)
+                 => RootId -> NodeType -> [NodeType] -> UpdateTree err
+                 -> Cmd err [DbTreeNode]
+findSharedDirect r nt nts fun = do
+  -- let rPrefix s = mconcat [ "[findSharedDirect] r = "
+  --                         , show r
+  --                         , ", nt = "
+  --                         , show nt
+  --                         , ", nts = "
+  --                         , show nts
+  --                         , " "
+  --                         , s ]
+  parent <- getNodeWith r (Proxy :: Proxy HyperdataAny)
+  let mParent = _node_parentId parent
+  case mParent of
+    Nothing -> pure []
+    Just parentId -> do
+      foldersSharedId <- findNodesId parentId [nt]
+      -- printDebug (rPrefix "foldersSharedId") foldersSharedId
+      trees           <- mapM (updateTree nts fun) foldersSharedId
+      -- printDebug (rPrefix "trees") trees
+      pure $ concat trees
+
+
+type UpdateTree err = ParentId -> [NodeType] -> NodeId -> Cmd err [DbTreeNode]
+
+updateTree :: HasTreeError err
+           => [NodeType] -> UpdateTree err -> RootId
+           -> Cmd err [DbTreeNode]
+updateTree nts fun r = do
+  folders       <- getNodeNode r
+  nodesSharedId <- mapM (fun r nts)
+                 $ map _nn_node2_id folders
   pure $ concat nodesSharedId
 
-sharedTree :: ParentId -> NodeId -> [NodeType] -> Cmd err [DbTreeNode]
-sharedTree p n nt = dbTree n nt
-               <&> map (\n' -> if _dt_nodeId n' == n 
+
+sharedTreeUpdate :: HasTreeError err => UpdateTree err
+sharedTreeUpdate p nt n = dbTree n nt
+               <&> map (\n' -> if (view dt_nodeId n') == n
+                                  -- && elem (fromDBid $ _dt_typeId n') [NodeGraph]
+                                  -- && not (elem (fromDBid $ _dt_typeId n') [NodeFile])
                                   then set dt_parentId (Just p) n'
                                   else n')
 
+publicTreeUpdate :: HasTreeError err => UpdateTree err
+publicTreeUpdate p nt n = dbTree n nt
+               <&> map (\n' -> if _dt_nodeId n' == n
+                                  -- && (fromDBid $ _dt_typeId n') /= NodeGraph
+                                  -- && not (elem (fromDBid $ _dt_typeId n') [NodeFile])
+                                  then set dt_parentId (Just p) n'
+                                  else n')
 
-shareNodeWith :: NodeId -> User -> Cmd err Int64
-shareNodeWith n u = do
-  r <- map _node_id <$> getRoot u
-  s <- case head r of
-      Nothing -> panic "no root id"
-      Just r' -> findNodesId r' [NodeFolderShared]
-  insertNodeNode $ map (\s' -> NodeNode s' n Nothing Nothing) s
 
--- TODO delete node, if not owned, then suppress the link only
 
 -- | findNodesId returns all nodes matching nodeType but the root (Nodeuser)
 findNodesId :: RootId -> [NodeType] -> Cmd err [NodeId]
@@ -96,60 +228,83 @@ findNodesId r nt = tail
                 <$> map _dt_nodeId
                 <$> dbTree r nt
 
-------------------------------------------------------------------------
-------------------------------------------------------------------------
--- | Returns the Tree of Nodes in Database
--- (without shared folders)
--- keeping this for teaching purpose only
-treeDB' :: HasTreeError err
-       => RootId
-       -> [NodeType]
-       -> Cmd err (Tree NodeTree)
-treeDB' r nodeTypes = 
-  (dbTree r nodeTypes <&> toTreeParent) >>= toTree
-  -- Same as (but easier to read) :
-  -- toTree =<< (toTreeParent <$> dbTree r nodeTypes)
-
-treeDB :: HasTreeError err
-       => RootId
-       -> [NodeType]
-       -> Cmd err (Tree NodeTree)
-treeDB r nodeTypes = do
-  mainRoot    <- dbTree r nodeTypes
-  sharedRoots <- findShared r nodeTypes
-  toTree      $ toTreeParent (mainRoot <> sharedRoots)
+findNodesWithType :: RootId -> [NodeType] -> [NodeType] -> Cmd err [DbTreeNode]
+findNodesWithType root target through =
+  filter isInTarget <$> dbTree root through
+    where
+      isInTarget n = List.elem (fromDBid $ view dt_typeId n)
+                   $ List.nub $ target <> through
 
+------------------------------------------------------------------------
 ------------------------------------------------------------------------
 toTree :: ( MonadError e m
-          , HasTreeError e)
+          , HasTreeError e
+          , MonadBase IO m )
        => Map (Maybe ParentId) [DbTreeNode]
        -> m (Tree NodeTree)
 toTree m =
     case lookup Nothing m of
-        Just [n] -> pure $ toTree' m n
-        Nothing  -> treeError NoRoot
-        Just []  -> treeError EmptyRoot
-        Just _   -> treeError TooManyRoots
-
-     where
-      toTree' :: Map (Maybe ParentId) [DbTreeNode]
-              -> DbTreeNode
-              -> Tree NodeTree
-      toTree' m' n =
-        TreeN (toNodeTree n) $
-          m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
+        Just [root] -> pure $ toTree' m root
+        Nothing     -> treeError NoRoot
+        Just []     -> treeError EmptyRoot
+        Just _r     -> treeError TooManyRoots
+
+      where
+        toTree' :: Map (Maybe ParentId) [DbTreeNode]
+                -> DbTreeNode
+                -> Tree NodeTree
+        toTree' m' root =
+          TreeN (toNodeTree root) $
+            -- | Lines below are equivalent computationally but not semantically
+            -- m' ^.. at (Just $ _dt_nodeId root) . _Just . each . to (toTree' m')
+            toListOf (at (Just $ _dt_nodeId root) . _Just . each . to (toTree' m')) m'
+
+        toNodeTree :: DbTreeNode
+                   -> NodeTree
+        toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromNodeTypeId tId) nId
 
 ------------------------------------------------------------------------
-toNodeTree :: DbTreeNode
-           -> NodeTree
-toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
-  where
-    nodeType = fromNodeTypeId tId
-------------------------------------------------------------------------
 toTreeParent :: [DbTreeNode]
              -> Map (Maybe ParentId) [DbTreeNode]
-toTreeParent = fromListWith (<>) . map (\n -> (_dt_parentId n, [n]))
+toTreeParent = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n]))
+------------------------------------------------------------------------
+-- toSubtreeParent' :: [DbTreeNode]
+--                 -> Map (Maybe ParentId) [DbTreeNode]
+-- toSubtreeParent' ns = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n])) $ nullifiedParents
+--   where
+--     nodeIds = Set.fromList $ map (\n -> unNodeId $ _dt_nodeId n) ns
+--     nullifiedParents = map nullifyParent ns
+--     nullifyParent dt@(DbTreeNode { _dt_parentId = Nothing }) = dt
+--     nullifyParent dt@(DbTreeNode { _dt_nodeId = nId
+--                                  , _dt_parentId = Just pId
+--                                  , _dt_typeId = tId
+--                                  , _dt_name = name }) =
+--       if Set.member (unNodeId pId) nodeIds then
+--         dt
+--       else
+--         DbTreeNode { _dt_nodeId = nId
+--                    , _dt_typeId = tId
+--                    , _dt_parentId = Nothing
+--                    , _dt_name = name }
+------------------------------------------------------------------------
+toSubtreeParent :: RootId
+                -> [DbTreeNode]
+                -> Map (Maybe ParentId) [DbTreeNode]
+toSubtreeParent r ns = fromListWith (\a b -> nub $ a <> b) . map (\n -> (_dt_parentId n, [n])) $ nullifiedParents
+  where
+    nullifiedParents = map nullifyParent ns
+    nullifyParent dt@(DbTreeNode { _dt_parentId = Nothing }) = dt
+    nullifyParent dt@(DbTreeNode { _dt_nodeId = nId
+                                 , _dt_parentId = _pId
+                                 , _dt_typeId = tId
+                                 , _dt_name = name }) =
+      if r == nId then
+        DbTreeNode { _dt_nodeId = nId
+                   , _dt_typeId = tId
+                   , _dt_parentId = Nothing
+                   , _dt_name = name }
+      else
+        dt
 ------------------------------------------------------------------------
 -- | Main DB Tree function
 dbTree :: RootId
@@ -213,8 +368,4 @@ isIn cId docId = ( == [Only True])
       WHERE nn.node1_id = ?
         AND nn.node2_id = ?;
   |] (cId, docId)
-
 -----------------------------------------------------
-
-
-