Merge branch 'dev-tree-reload' of...

Merge branch 'dev-tree-reload' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantext into dev-merge

src/Gargantext/API/Metrics.hs

@@ -324,17 +324,11 @@ type TreeApi = Summary " Tree API"
                 :> QueryParamR "listType"   ListType
                 :> Post '[JSON] ()
           :<|> "hash" :>
-                  Summary "Tree Hash"
+                 Summary "Tree Hash"
               :> QueryParam  "list"       ListId
               :> QueryParamR "ngramsType" TabType
               :> QueryParamR "listType"   ListType
               :> Get '[JSON] Text
-
-                -- Depending on the Type of the Node, we could post
-                -- New documents for a corpus
-                -- New map list terms
-             -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
-
 treeApi :: NodeId -> GargServer TreeApi
 treeApi id' = getTree id'
          :<|> updateTree id'

src/Gargantext/API/Node.hs

@@ -292,10 +292,15 @@ pairWith cId aId lId = do
 
 
 ------------------------------------------------------------------------
-type TreeAPI   = QueryParams "type" NodeType :> Get '[JSON] (Tree NodeTree)
+type TreeAPI   = QueryParams "type" NodeType
+                  :> Get '[JSON] (Tree NodeTree)
+                  :<|> "first-level"
+                      :> QueryParams "type" NodeType
+                      :> Get '[JSON] (Tree NodeTree)
 
 treeAPI :: NodeId -> GargServer TreeAPI
-treeAPI = tree TreeAdvanced
+treeAPI id = tree TreeAdvanced id
+        :<|> tree TreeFirstLevel id
 
 ------------------------------------------------------------------------
 -- | TODO Check if the name is less than 255 char

src/Gargantext/API/ThrowAll.hs

@@ -15,10 +15,11 @@ Portability : POSIX
 
 module Gargantext.API.ThrowAll where
 
-import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Except (MonadError(..))
 import Control.Lens ((#))
 import Servant
 import Servant.Auth.Server (AuthResult(..))
+
 import Gargantext.Prelude
 import Gargantext.API.Prelude (GargServerM, _ServerError)
 import Gargantext.API.Routes (GargPrivateAPI, serverPrivateGargAPI')
@@ -46,4 +47,4 @@ instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
 serverPrivateGargAPI :: GargServerM env err GargPrivateAPI
 serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
--- Here throwAll' requires a concrete type for the monad.
+-- Here throwAll' requires a concrete type for the monad.
\ No newline at end of file

src/Gargantext/Core/Types.hs

@@ -27,7 +27,7 @@ module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
                              ) where
 
 import Control.Lens (Prism', (#))
-import Control.Monad.Error.Class (MonadError, throwError)
+import Control.Monad.Except (MonadError(throwError))
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import Data.Monoid
@@ -38,11 +38,12 @@ import Data.Swagger (ToSchema(..))
 import Data.Text (Text, unpack)
 import Data.Validity
 import GHC.Generics
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+
 import Gargantext.Core.Types.Main
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Core.Utils.Prefix (unPrefix, wellNamedSchema)
 import Gargantext.Prelude
-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
 ------------------------------------------------------------------------
 data Ordering = Down | Up

src/Gargantext/Database/Prelude.hs

@@ -15,7 +15,7 @@ module Gargantext.Database.Prelude where
 
 import Control.Exception
 import Control.Lens (Getter, view)
-import Control.Monad.Error.Class -- (MonadError(..), Error)
+-- import Control.Monad.Error.Class -- (MonadError(..), Error)
 import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.Random

src/Gargantext/Database/Query/Table/Node/Error.hs

@@ -10,12 +10,14 @@ Portability : POSIX
 
 module Gargantext.Database.Query.Table.Node.Error where
 
+import Control.Lens (Prism', (#), (^?))
+import Control.Monad.Except (MonadError(..))
 import Data.Text (Text)
+
+import Prelude hiding (null, id, map, sum)
+
 import Gargantext.Database.Admin.Types.Node (NodeId)
-import Control.Lens (Prism', (#), (^?))
-import Control.Monad.Error.Class (MonadError(..))
 import Gargantext.Prelude hiding (sum, head)
-import Prelude hiding (null, id, map, sum)
 
 ------------------------------------------------------------------------
 data NodeError = NoListFound

src/Gargantext/Database/Query/Tree.hs

@@ -35,12 +35,16 @@ module Gargantext.Database.Query.Tree
   where
 
 import Control.Lens (view, toListOf, at, each, _Just, to, set, makeLenses)
-import Control.Monad.Error.Class (MonadError())
+import Control.Monad.Except (MonadError())
 import Data.List (tail, concat, nub)
 import Data.Map (Map, fromListWith, lookup)
+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.Types.Main (NodeTree(..), Tree(..))
 import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId, fromNodeTypeId)
 import Gargantext.Database.Admin.Types.Node
@@ -48,7 +52,6 @@ import Gargantext.Database.Prelude (Cmd, runPGSQuery)
 import Gargantext.Database.Query.Table.NodeNode (getNodeNode)
 import Gargantext.Database.Query.Tree.Error
 import Gargantext.Database.Schema.NodeNode (NodeNodePoly(..))
-import Gargantext.Prelude
 
 ------------------------------------------------------------------------
 data DbTreeNode = DbTreeNode { _dt_nodeId   :: NodeId
@@ -64,7 +67,7 @@ instance Eq DbTreeNode where
 
 ------------------------------------------------------------------------
 
-data TreeMode = TreeBasic | TreeAdvanced
+data TreeMode = TreeBasic | TreeAdvanced | TreeFirstLevel
 
 -- | Returns the Tree of Nodes in Database
 tree :: HasTreeError err
@@ -74,6 +77,7 @@ tree :: HasTreeError err
      -> 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)
@@ -98,6 +102,17 @@ tree_advanced r nodeTypes = do
   publicRoots <- findNodes r Public  nodeTypes
   toTree      $ toTreeParent (mainRoot <> sharedRoots <> publicRoots)
 
+-- | Fetch only first level of tree
+tree_first_level :: HasTreeError err
+                 => RootId
+                 -> [NodeType]
+                 -> Cmd err (Tree NodeTree)
+tree_first_level r nodeTypes = do
+  mainRoot    <- findNodes r Private nodeTypes
+  sharedRoots <- findNodes r Shared  nodeTypes
+  publicRoots <- findNodes r Public  nodeTypes
+  toTree $ toSubtreeParent (mainRoot <> sharedRoots <> publicRoots)
+
 ------------------------------------------------------------------------
 data NodeMode = Private | Shared | Public
 
@@ -159,7 +174,8 @@ findNodesId r nt = tail
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 toTree :: ( MonadError e m
-          , HasTreeError e)
+          , HasTreeError e
+          , MonadBase IO m )
        => Map (Maybe ParentId) [DbTreeNode]
        -> m (Tree NodeTree)
 toTree m =
@@ -167,27 +183,47 @@ toTree m =
         Just [n] -> pure $ toTree' m n
         Nothing  -> treeError NoRoot
         Just []  -> treeError EmptyRoot
-        Just _   -> treeError TooManyRoots
+        Just r   -> treeError TooManyRoots
 
      where
-      toTree' :: Map (Maybe ParentId) [DbTreeNode]
-              -> DbTreeNode
-              -> Tree NodeTree
-      toTree' m' n =
-        TreeN (toNodeTree n) $
-          -- | Lines below are equivalent computationally but not semantically
-          -- m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
-          toListOf (at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')) m'
-
-      toNodeTree :: DbTreeNode
-                 -> NodeTree
-      toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromNodeTypeId tId) nId
+       toTree' :: Map (Maybe ParentId) [DbTreeNode]
+               -> DbTreeNode
+               -> Tree NodeTree
+       toTree' m' n =
+         TreeN (toNodeTree n) $
+           -- | Lines below are equivalent computationally but not semantically
+           -- m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
+           toListOf (at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')) m'
+
+       toNodeTree :: DbTreeNode
+                  -> NodeTree
+       toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromNodeTypeId tId) nId
+
 
 ------------------------------------------------------------------------
 toTreeParent :: [DbTreeNode]
              -> Map (Maybe ParentId) [DbTreeNode]
 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 }
+------------------------------------------------------------------------
 -- | Main DB Tree function
 dbTree :: RootId
        -> [NodeType]

src/Gargantext/Database/Query/Tree/Error.hs

@@ -15,7 +15,8 @@ module Gargantext.Database.Query.Tree.Error
   where
 
 import Control.Lens (Prism', (#))
-import Control.Monad.Error.Class (MonadError(throwError))
+import Control.Monad.Except (MonadError(throwError))
+
 import Gargantext.Prelude
 
 ------------------------------------------------------------------------
@@ -33,7 +34,7 @@ class HasTreeError e where
   _TreeError :: Prism' e TreeError
 
 treeError :: ( MonadError e m
-             , HasTreeError e)
+             , HasTreeError e )
              => TreeError
              -> m a
 treeError te = throwError $ _TreeError # te