Basic Remote API testing

gargantext.cabal

@@ -796,6 +796,7 @@ test-suite garg-test-tasty
       CLI.Phylo.Common
       Paths_gargantext
       Test.API.Private.Move
+      Test.API.Private.Remote
       Test.API.Private.Share
       Test.API.Private.Table
       Test.API.Authentication
@@ -865,6 +866,7 @@ test-suite garg-test-hspec
       Test.API.Notifications
       Test.API.Private
       Test.API.Private.Move
+      Test.API.Private.Remote
       Test.API.Private.Share
       Test.API.Private.Table
       Test.API.Routes

src/Gargantext/API/Routes/Client.hs

@@ -13,6 +13,7 @@ import Gargantext.API.Errors (GargErrorScheme(..))
 import Gargantext.API.Routes.Named
 import Gargantext.API.Routes.Named.Private (mkPrivateAPI, remoteAPI)
 import Gargantext.API.Routes.Named.Remote qualified as Named
+import Gargantext.Database.Admin.Types.Node
 import Gargantext.Prelude
 import Network.HTTP.Types qualified as H
 import Servant.API.WebSocket qualified as WS
@@ -38,7 +39,7 @@ clientRoutes = genericClient
 
 remoteImportClient :: Auth.Token
                    -> C.ConduitT () Named.RemoteBinaryData IO ()
-                   -> ClientM ()
+                   -> ClientM [NodeId]
 remoteImportClient (S.Token . TE.encodeUtf8 -> token) c =
   clientRoutes & apiWithCustomErrorScheme
                & ($ GES_new)
@@ -53,3 +54,21 @@ remoteImportClient (S.Token . TE.encodeUtf8 -> token) c =
                & Named.remoteAPI
                & Named.remoteImportEp
                & ($ c)
+
+remoteExportClient :: Auth.Token
+                   -> Named.RemoteExportRequest
+                   -> ClientM [NodeId]
+remoteExportClient (S.Token . TE.encodeUtf8 -> token) r =
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & remoteAPI
+               & Named.remoteAPI
+               & Named.remoteExportEp
+               & ($ r)

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

@@ -77,7 +77,7 @@ instance ToSchema RemoteBinaryData where
   declareNamedSchema _ = pure $ NamedSchema (Just "RemoteExportRequest") binarySchema
 
 data RemoteAPI' mode = RemoteAPI'
-  { remoteExportEp :: mode :- "export" :> ReqBody '[JSON] RemoteExportRequest :> PolicyChecked (Post '[JSON] ())
+  { remoteExportEp :: mode :- "export" :> ReqBody '[JSON] RemoteExportRequest :> PolicyChecked (Post '[JSON] [NodeId])
   , remoteImportEp :: mode :- "import" :> StreamBody NoFraming OctetStream (C.ConduitT () RemoteBinaryData IO ())
-                                       :> Post '[JSON] ()
+                                       :> Post '[JSON] [NodeId]
   } deriving Generic

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE BangPatterns #-}
 
 module Gargantext.API.Server.Named.Remote (
   remoteAPI
@@ -13,7 +14,6 @@ import Conduit
 import Control.Exception.Safe qualified as Safe
 import Control.Exception (toException)
 import Control.Lens (view, (#))
-import Control.Monad
 import Control.Monad.Except (throwError)
 import Data.Aeson qualified as JSON
 import Data.ByteString.Builder qualified as B
@@ -37,6 +37,7 @@ import Gargantext.Database.Query.Table.Node (getNode, insertNodeWithHyperdata)
 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)
 
@@ -56,7 +57,7 @@ remoteImportHandler :: forall err env m.
                     (HasNodeError err, HasBackendInternalError err, IsDBCmd env err m, MonadIO m)
                     => AuthenticatedUser
                     -> ConduitT () Named.RemoteBinaryData IO ()
-                    -> m ()
+                    -> m [NodeId]
 remoteImportHandler loggedInUser c = do
   chunks <- liftIO $ sourceToList $ c .| C.map (B.byteString . Named.getRemoteBinaryData)
   -- FIXME(adn): We have to find a way to deserialise this into a streaming fashion and
@@ -66,23 +67,23 @@ remoteImportHandler loggedInUser c = do
     Right [] -> throwError $ _BackendInternalError # InternalUnexpectedError (toException $ userError $ "Deserialization error: empty list")
     Right (x:xs) -> do
       -- Attempts to insert nodes a we go along.
-      rootNode <- inserter Nothing x
-      void $ foldlM insert_remote rootNode xs
+      rootNode <- inserter [] x
+      foldlM inserter rootNode xs
   where
 
-    inserter :: Maybe ParentId -> Node JSON.Value -> m NodeId
-    inserter p x = case lookupDBid $ _node_typename x of
-      Nothing -> error "remoteImportHandler: impossible."
-      Just ty -> insertNodeWithHyperdata ty (_node_name x) (_node_hyperdata x) p (_auth_user_id loggedInUser)
+    inserter :: [NodeId] -> Node JSON.Value -> m [NodeId]
+    inserter !acc 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
 
-    insert_remote :: NodeId -> Node JSON.Value -> m NodeId
-    insert_remote previousNode = inserter (Just previousNode)
 
 remoteExportHandler :: ( MonadIO m, Safe.MonadCatch m
                        , IsGargServer err env m
                        )
                     => Named.RemoteExportRequest
-                    -> m ()
+                    -> m [NodeId]
 remoteExportHandler Named.RemoteExportRequest{..} = do
   mgr  <- view gargHttpManager
   -- FIXME(adn) Here I should somehow need to get all the children of the
@@ -95,7 +96,7 @@ streamEncoder :: (MonadIO m, Serialise a) => a -> ConduitT () Named.RemoteBinary
 streamEncoder = CL.sourceList . map Named.RemoteBinaryData . BL.toChunks . serialise
 
 -- | Returns a conduit which can be used to decode
-streamDecode :: Either ClientError () -> IO ()
+streamDecode :: Either ClientError [NodeId] -> IO [NodeId]
 streamDecode = \case
   Left err -> Safe.throwIO $ InternalUnexpectedError (toException $ userError $ show err)
-  Right _  -> pure ()
+  Right x  -> pure x

test/Test/API/Private.hs

@@ -20,6 +20,7 @@ import Servant.Client.Streaming
 import Servant.Client.Generic (genericClient)
 import Test.API.Prelude
 import Test.API.Private.Move  qualified as Move
+import Test.API.Private.Remote  qualified as Remote
 import Test.API.Private.Share qualified as Share
 import Test.API.Private.Table qualified as Table
 import Test.API.Routes (mkUrl, get_node, get_tree)
@@ -111,3 +112,5 @@ tests = sequential $ do
     Table.tests
   describe "Move API" $ do
     Move.tests
+  describe "Remote API" $ do
+    Remote.tests

test/Test/API/Private/Remote.hs

+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Test.API.Private.Remote (
+    tests
+  ) where
+
+import Control.Lens
+import Gargantext.API.Admin.EnvTypes (Mode(..))
+import Gargantext.API.Errors
+import Gargantext.API (makeApp)
+import Gargantext.API.Routes.Client (remoteExportClient)
+import Gargantext.API.Routes.Named.Remote (RemoteExportRequest(..))
+import Gargantext.Core.Types.Individu
+import Gargantext.Core.Types (NodeId(UnsafeMkNodeId))
+import Gargantext.Prelude
+import Gargantext.System.Logging
+import Network.Wai.Handler.Warp qualified as Warp
+import Network.Wai qualified as Wai
+import Servant.Client.Streaming
+import Test.API.Prelude
+import Test.API.Setup
+import Test.Database.Setup
+import Test.Database.Types
+import Test.Hspec (Spec, it, aroundAll, describe, sequential, shouldBe)
+import Test.Hspec.Wai.Internal (withApplication)
+import Test.Utils
+
+-- | Helper to let us test transferring data between two instances.
+withTwoServerInstances :: (SpecContext (TestEnv,Wai.Application,Warp.Port) -> IO ()) -> IO ()
+withTwoServerInstances action =
+  withTestDB $ \testEnv1 -> do
+    withTestDB $ \testEnv2 -> do
+      garg1App <- withLoggerHoisted Mock $ \ioLogger -> do
+                   env <- newTestEnv testEnv1 ioLogger server1Port
+                   makeApp env
+      garg2App <- withLoggerHoisted Mock $ \ioLogger -> do
+                   env <- newTestEnv testEnv2 ioLogger server2Port
+                   makeApp env
+
+      testWithApplicationOnPort (pure garg1App) server1Port $
+        testWithApplicationOnPort (pure garg2App) server2Port $
+          action (SpecContext testEnv1 server1Port garg1App (testEnv2,garg2App,server2Port))
+  where
+    server1Port = 8008
+    server2Port = 9008
+
+tests :: Spec
+tests = sequential $ aroundAll withTwoServerInstances $ do
+  describe "Prelude" $ do
+    it "setup DB triggers" $ \SpecContext{..} -> do
+      forM_ [ _sctx_env, _sctx_data ^. _1 ] $ \e -> do
+        setupEnvironment e
+        void $ createAliceAndBob e
+
+    describe "Copying nodes across instances" $ do
+
+      it "should forbid moving a node the user doesn't own" $ \(SpecContext testEnv1 server1Port app1 (_testEnv2, _app2, server2Port)) -> do
+        withApplication app1 $ do
+          withValidLogin server1Port "alice" (GargPassword "alice") $ \aliceClientEnv aliceToken -> do
+            withValidLogin server2Port "bob" (GargPassword "bob") $ \_bobClientEnv bobToken -> do
+              liftIO $ do
+                bobPublicFolderId <- getRootPublicFolderIdForUser testEnv1 (UserName "bob")
+                let rq = RemoteExportRequest { _rer_node_id = bobPublicFolderId
+                                             , _rer_instance_url  = fromMaybe (panicTrace "impossible") $ parseBaseUrl "http://localhost:9008"
+                                             , _rer_instance_auth = bobToken
+                                             }
+                res <- runClientM (remoteExportClient aliceToken rq) aliceClientEnv
+                res `shouldFailWith` EC_403__policy_check_error
+
+      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")
+            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 <- checkEither $ runClientM (remoteExportClient aliceToken rq) aliceClientEnv
+                res `shouldBe` [ UnsafeMkNodeId 16 ]

test/Test/API/Setup.hs

@@ -9,6 +9,7 @@ module Test.API.Setup (
   , setupEnvironment
   , createAliceAndBob
   , dbEnvSetup
+  , newTestEnv
   ) where
 
 import Control.Concurrent.Async qualified as Async