Restrict export of nodes to only a few types

src/Gargantext/API/Errors.hs

@@ -176,6 +176,8 @@ nodeErrorToFrontendError ne = case ne of
     -> mkFrontendErrShow $ FE_node_is_read_only nodeId reason
   MoveError sourceId targetId reason
     -> mkFrontendErrShow $ FE_node_move_error sourceId targetId reason
+  NodeNotExportable nodeId reason
+    -> mkFrontendErrShow $ FE_node_export_error nodeId reason
 
   -- backward-compatibility shims, to remove eventually.
   DoesNotExist nid

src/Gargantext/API/Errors/Types.hs

@@ -286,6 +286,10 @@ data instance ToFrontendErrorData 'EC_403__node_move_error =
   FE_node_move_error { nme_source_id :: !NodeId, nme_target_id :: !NodeId, nme_reason :: !T.Text }
   deriving (Show, Eq, Generic)
 
+data instance ToFrontendErrorData 'EC_403__node_export_error =
+  FE_node_export_error { nee_node_id :: !NodeId, nee_reason :: !T.Text }
+  deriving (Show, Eq, Generic)
+
 --
 -- validation errors
 --
@@ -522,6 +526,15 @@ instance FromJSON (ToFrontendErrorData 'EC_403__node_move_error) where
     nme_reason  <- o .: "reason"
     pure FE_node_move_error{..}
 
+instance ToJSON (ToFrontendErrorData 'EC_403__node_export_error) where
+  toJSON FE_node_export_error{..} =
+    object [ "node_id" .= toJSON nee_node_id, "reason" .= toJSON nee_reason ]
+instance FromJSON (ToFrontendErrorData 'EC_403__node_export_error) where
+  parseJSON = withObject "FE_node_move_error" $ \o -> do
+    nee_node_id <- o .: "node_id"
+    nee_reason  <- o .: "reason"
+    pure FE_node_export_error{..}
+
 --
 -- validation errors
 --
@@ -736,6 +749,9 @@ instance FromJSON FrontendError where
       EC_403__node_move_error -> do
         (fe_data :: ToFrontendErrorData 'EC_403__node_move_error) <- o .: "data"
         pure FrontendError{..}
+      EC_403__node_export_error -> do
+        (fe_data :: ToFrontendErrorData 'EC_403__node_export_error) <- o .: "data"
+        pure FrontendError{..}
 
       -- validation error
       EC_400__validation_error -> do

src/Gargantext/API/Errors/Types/Backend.hs

@@ -35,6 +35,7 @@ data BackendErrorCode
   | EC_400__node_needs_configuration
   | EC_403__node_is_read_only
   | EC_403__node_move_error
+  | EC_403__node_export_error
   -- validation errors
   | EC_400__validation_error
   -- policy check errors

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

@@ -14,13 +14,14 @@ import Conduit
 import Control.Exception.Safe qualified as Safe
 import Control.Exception (toException)
 import Control.Lens (view, (#))
-import Control.Monad.Except (throwError)
+import Control.Monad.Except (throwError, MonadError)
 import Data.Aeson qualified as JSON
 import Data.ByteString.Builder qualified as B
 import Data.ByteString.Lazy qualified as BL
 import Data.Conduit.Combinators qualified as C
 import Data.Conduit.List qualified as CL
 import Data.Foldable (foldlM)
+import Data.Text qualified as T
 import Gargantext.API.Admin.Auth
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..))
 import Gargantext.API.Auth.PolicyCheck (remoteExportChecks)
@@ -32,7 +33,7 @@ import Gargantext.Core.Config
 import Gargantext.Core (lookupDBid)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude (IsDBCmd)
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError, nodeError, NodeError (..))
 import Gargantext.Database.Query.Table.Node (getNode, insertNodeWithHyperdata)
 import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Orphans ()
@@ -88,10 +89,24 @@ 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
-  liftIO (withClientM (remoteImportClient _rer_instance_auth (streamEncoder node)) (mkClientEnv mgr _rer_instance_url) streamDecode)
+  node <- getNode _rer_node_id
+  checkNodeTypeAllowed node
+  liftIO (withClientM (remoteImportClient _rer_instance_auth (streamEncoder [node])) (mkClientEnv mgr _rer_instance_url) streamDecode)
               `Safe.catch` \(e :: BackendInternalError) -> throwError $ _BackendInternalError # e
 
+checkNodeTypeAllowed :: (MonadError e m, HasNodeError e) => Node a -> m ()
+checkNodeTypeAllowed n
+  | Just nty <- lookupDBid (_node_typename n)
+  , nty `elem` exportableNodeTypes
+  = pure ()
+  | otherwise
+  = let msg = "It's possible to export only the following node of type: " <> T.intercalate "," (map (T.pack . show) exportableNodeTypes)
+    in nodeError $ NodeNotExportable (_node_id n) msg
+
+-- | At the moment we support only export corpus nodes and their children (i.e. "Docs", "Terms", "Graph").
+exportableNodeTypes :: [NodeType]
+exportableNodeTypes = [ NodeCorpus, NodeCorpusV3, NodeTexts, NodeGraph, NodeList ]
+
 streamEncoder :: (MonadIO m, Serialise a) => a -> ConduitT () Named.RemoteBinaryData m ()
 streamEncoder = CL.sourceList . map Named.RemoteBinaryData . BL.toChunks . serialise
 

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

@@ -85,6 +85,7 @@ data NodeError = NoListFound ListId
                | DoesNotExist NodeId
                | NodeIsReadOnly NodeId T.Text
                | MoveError NodeId NodeId T.Text
+               | NodeNotExportable NodeId T.Text
 
 instance Prelude.Show NodeError
   where
@@ -101,6 +102,7 @@ instance Prelude.Show NodeError
     show (DoesNotExist n)   = "Node does not exist (" <> show n <> ")"
     show (NodeIsReadOnly n reason) = "Node " <> show n <> " is read only, edits not allowed. Reason: " <> T.unpack reason
     show (MoveError s t reason) = "Moving " <> show s <> " to " <> show t <> " failed: " <> T.unpack reason
+    show (NodeNotExportable nid reason) = "Node " <> show nid <> " is not exportable: " <> show reason
 
 instance ToJSON NodeError where
   toJSON (DoesNotExist n) =

test/Test/API/Private/Remote.hs

@@ -72,12 +72,26 @@ tests = sequential $ aroundAll withTwoServerInstances $ do
       it "supports trivial transfer between instances" $ \(SpecContext testEnv1 server1Port app1 (_testEnv2, _app2, server2Port)) -> do
         withApplication app1 $ do
           withValidLogin server1Port "alice" (GargPassword "alice") $ \aliceClientEnv aliceToken -> do
-            folderId <- liftIO $ getRootPublicFolderIdForUser testEnv1 (UserName "alice")
+            corpusId <- liftIO $ newCorpusForUser testEnv1 "alice"
             withValidLogin server2Port "bob" (GargPassword "bob") $ \_bobClientEnv bobToken -> do
               liftIO $ do
-                let rq = RemoteExportRequest { _rer_node_id = folderId
+                let rq = RemoteExportRequest { _rer_node_id = corpusId
                                              , _rer_instance_url  = fromMaybe (panicTrace "impossible") $ parseBaseUrl "http://localhost:9008"
                                              , _rer_instance_auth = bobToken
                                              }
                 res <- checkEither $ runClientM (remoteExportClient aliceToken rq) aliceClientEnv
                 res `shouldBe` [ UnsafeMkNodeId 16 ]
+
+      -- Certain node types (like private, share, etc) shouldn't be transferred.
+      it "forbids transferring certain node types" $ \(SpecContext testEnv1 server1Port app1 (_testEnv2, _app2, server2Port)) -> do
+        withApplication app1 $ do
+          withValidLogin server1Port "alice" (GargPassword "alice") $ \aliceClientEnv aliceToken -> do
+            folderId <- liftIO $ newPrivateFolderForUser testEnv1 "alice"
+            withValidLogin server2Port "bob" (GargPassword "bob") $ \_bobClientEnv bobToken -> do
+              liftIO $ do
+                let rq = RemoteExportRequest { _rer_node_id = folderId
+                                             , _rer_instance_url  = fromMaybe (panicTrace "impossible") $ parseBaseUrl "http://localhost:9008"
+                                             , _rer_instance_auth = bobToken
+                                             }
+                res <- runClientM (remoteExportClient aliceToken rq) aliceClientEnv
+                res `shouldFailWith` EC_403__node_export_error

test/Test/Instances.hs

@@ -479,6 +479,9 @@ genFrontendErr be = do
       -> do sId <- arbitrary
             tId <- arbitrary
             pure $ Errors.mkFrontendErr' txt $ Errors.FE_node_move_error sId tId "generic reason"
+    Errors.EC_403__node_export_error
+      -> do nId <- arbitrary
+            pure $ Errors.mkFrontendErr' txt $ Errors.FE_node_export_error nId "generic reason"
 
     -- validation error
     Errors.EC_400__validation_error