Support trees of export nodes (to be tested)

src/Gargantext/API/Server/Named/Remote.hs

@@ -34,13 +34,13 @@ import Gargantext.Core (lookupDBid)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (IsDBCmd)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError, nodeError, NodeError (..))
-import Gargantext.Database.Query.Table.Node (getNode, insertNodeWithHyperdata)
+import Gargantext.Database.Query.Table.Node (insertNodeWithHyperdata, getNodes)
 import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Orphans ()
 import Prelude
-import Protolude.Safe (headMay)
 import Servant.Client.Streaming (mkClientEnv, withClientM, ClientError)
 import Servant.Server.Generic (AsServerT)
+import Gargantext.Core.Types.Main
 
 remoteAPI :: (MonadIO m, IsGargServer env BackendInternalError m)
           => AuthenticatedUser
@@ -52,7 +52,7 @@ remoteAPI authenticatedUser = Named.RemoteAPI $
     , remoteImportEp = remoteImportHandler authenticatedUser
     }
 
-type ExpectedPayload = [Node JSON.Value]
+type ExpectedPayload = Tree (Node JSON.Value)
 
 remoteImportHandler :: forall err env m.
                     (HasNodeError err, HasBackendInternalError err, IsDBCmd env err m, MonadIO m)
@@ -65,19 +65,24 @@ remoteImportHandler loggedInUser c = do
   -- attempt insertion one element of the list at the time.
   case deserialiseOrFail @ExpectedPayload (B.toLazyByteString $ mconcat chunks) of
     Left err -> throwError $ _BackendInternalError # InternalUnexpectedError (toException $ userError $ "Deserialization error: " ++ show err)
-    Right [] -> throwError $ _BackendInternalError # InternalUnexpectedError (toException $ userError $ "Deserialization error: empty list")
-    Right (x:xs) -> do
+    Right (TreeN x xs) -> do
       -- Attempts to insert nodes a we go along.
-      rootNode <- inserter [] x
-      foldlM inserter rootNode xs
+      rootNode <- insertNode Nothing x
+      foldlM (insertTrees (Just rootNode)) [rootNode] xs
   where
 
-    inserter :: [NodeId] -> Node JSON.Value -> m [NodeId]
-    inserter !acc x = case lookupDBid $ _node_typename x of
+    insertNode :: Maybe NodeId -> Node JSON.Value -> m NodeId
+    insertNode mb_parent x = case lookupDBid $ _node_typename x of
       Nothing -> throwError $ _BackendInternalError # InternalUnexpectedError (toException $ userError $ "remoteImportHandler: impossible, node with invalid type.")
       Just ty -> do
-        new_node <- insertNodeWithHyperdata ty (_node_name x) (_node_hyperdata x) (headMay acc) (_auth_user_id loggedInUser)
-        pure $ new_node : acc
+        new_node <- insertNodeWithHyperdata ty (_node_name x) (_node_hyperdata x) mb_parent (_auth_user_id loggedInUser)
+        pure new_node
+
+    insertTrees :: Maybe NodeId -> [NodeId] -> Tree (Node JSON.Value) -> m [NodeId]
+    insertTrees currentParent !acc (TreeN x xs) = do
+      childrenRoot <- insertNode currentParent x
+      (`mappend` acc) <$> foldlM (insertTrees (Just childrenRoot)) [childrenRoot] xs
+
 
 
 remoteExportHandler :: ( MonadIO m, Safe.MonadCatch m
@@ -87,13 +92,16 @@ remoteExportHandler :: ( MonadIO m, Safe.MonadCatch m
                     -> m [NodeId]
 remoteExportHandler Named.RemoteExportRequest{..} = do
   mgr  <- view gargHttpManager
-  -- FIXME(adn) Here I should somehow need to get all the children of the
-  -- node so that I can recostruct proper semantic context.
-  node <- getNode _rer_node_id
-  checkNodeTypeAllowed node
-  liftIO (withClientM (remoteImportClient _rer_instance_auth (streamEncoder [node])) (mkClientEnv mgr _rer_instance_url) streamDecode)
+  nodes <- getNodes _rer_node_id
+  checkNodesTypeAllowed nodes
+  liftIO (withClientM (remoteImportClient _rer_instance_auth (streamEncoder nodes)) (mkClientEnv mgr _rer_instance_url) streamDecode)
               `Safe.catch` \(e :: BackendInternalError) -> throwError $ _BackendInternalError # e
 
+checkNodesTypeAllowed :: (MonadError e m, HasNodeError e) => Tree (Node a) -> m ()
+checkNodesTypeAllowed (TreeN r xs) = do
+  checkNodeTypeAllowed r
+  mapM_ checkNodesTypeAllowed xs
+
 checkNodeTypeAllowed :: (MonadError e m, HasNodeError e) => Node a -> m ()
 checkNodeTypeAllowed n
   | Just nty <- lookupDBid (_node_typename n)

src/Gargantext/Core/Types/Main.hs

@@ -13,11 +13,13 @@ Portability : POSIX
 
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE BangPatterns #-}
 
 -----------------------------------------------------------------------
 module Gargantext.Core.Types.Main where
 ------------------------------------------------------------------------
 
+import Codec.Serialise.Class
 import Data.Bimap (Bimap)
 import Data.Bimap qualified as Bimap
 import Data.Swagger ( ToSchema(..), ToParamSchema, genericDeclareNamedSchema )
@@ -29,8 +31,8 @@ import Gargantext.Core.Utils.Swagger (wellNamedSchema)
 import Gargantext.Database.Admin.Types.Node  -- (NodeType(..), Node, Hyperdata(..))
 import Gargantext.Prelude
 import Servant.API (FromHttpApiData(..), ToHttpApiData(..))
-import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import Test.QuickCheck (elements)
 
 type CorpusName = Text
 ------------------------------------------------------------------------
@@ -118,8 +120,44 @@ fromListTypeId = flip Bimap.lookupR listTypeIds
 data Tree a = TreeN { _tn_node :: a, _tn_children :: [Tree a] }
   deriving (Show, Read, Eq, Generic, Ord)
 
+instance Serialise a => Serialise (Tree a) where
+
 instance NFData a => NFData (Tree a) where
 
+instance Functor Tree where
+    fmap = fmapTree
+    x <$ TreeN _ ts = TreeN x (map (x <$) ts)
+
+fmapTree :: (a -> b) -> Tree a -> Tree b
+fmapTree f (TreeN x ts) = TreeN (f x) (map (fmapTree f) ts)
+
+instance Traversable Tree where
+  traverse f = go
+    where go (TreeN x ts) = liftA2 TreeN (f x) (traverse go ts)
+  {-# INLINE traverse #-}
+
+instance Foldable Tree where
+    fold = foldMap identity
+    {-# INLINABLE fold #-}
+
+    foldMap = foldMapDefault
+    {-# INLINE foldMap #-}
+
+    foldr f z = \t -> go t z  -- Use a lambda to allow inlining with two arguments
+      where
+        go (TreeN x ts) = f x . foldr (\t k -> go t . k) identity ts
+    {-# INLINE foldr #-}
+
+    foldl' f = go
+      where go !z (TreeN x ts) = foldl' go (f z x) ts
+    {-# INLINE foldl' #-}
+
+    null _ = False
+    {-# INLINE null #-}
+
+    elem = any . (==)
+    {-# INLINABLE elem #-}
+
 $(deriveJSON (unPrefix "_tn_") ''Tree)
 
 instance (Typeable a, ToSchema a) => ToSchema (Tree a) where