Proper error handling for remote import and export handlers

src/Gargantext/API/Errors/Types.hs

@@ -35,6 +35,7 @@ module Gargantext.API.Errors.Types (
   , GraphQLError(..)
   , ToFrontendErrorData(..)
   , AccessPolicyErrorReason(..)
+  , HasBackendInternalError(..)
 
   -- * Constructing frontend errors
   , mkFrontendErrNoDiagnostic
@@ -67,6 +68,7 @@ import Gargantext.Prelude hiding (Location, WithStacktrace)
 import Gargantext.Utils.Dict (Dict(..))
 import Gargantext.Utils.Jobs.Monad qualified as Jobs
 import Servant (ServerError)
+import Control.Lens.Prism (prism')
 
 -- | A 'WithStacktrace' carries an error alongside its
 -- 'CallStack', to be able to print the correct source location
@@ -121,6 +123,12 @@ data BackendInternalError
 
 makePrisms ''BackendInternalError
 
+class HasBackendInternalError e where
+  _BackendInternalError :: Prism' e BackendInternalError
+
+instance HasBackendInternalError BackendInternalError where
+  _BackendInternalError = prism' identity Just
+
 instance ToJSON BackendInternalError where
   toJSON (InternalJobError s) =
     object [ ("status", toJSON ("IsFailure" :: Text))

src/Gargantext/API/Prelude.hs

@@ -17,11 +17,12 @@ module Gargantext.API.Prelude
   , HasServerError(..)
   , serverError ) where
 
+import Control.Exception.Safe qualified as Safe
 import Control.Lens ((#))
 import Control.Monad.Random (MonadRandom)
 import Gargantext.API.Admin.Auth.Types (AuthenticationError)
 import Gargantext.API.Errors.Class (HasAuthenticationError, _AuthenticationError)
-import Gargantext.API.Errors.Types (HasServerError(..), serverError)
+import Gargantext.API.Errors.Types (HasServerError(..), serverError, HasBackendInternalError)
 import Gargantext.Core.Notifications.CentralExchange.Types (HasCentralExchangeNotification)
 import Gargantext.Core.Config (HasConfig, HasManager)
 import Gargantext.Core.Mail.Types (HasMail)
@@ -54,6 +55,7 @@ type ErrC err =
   , HasValidationError     err
   , HasTreeError           err
   , HasServerError         err
+  , HasBackendInternalError err
   , HasAuthenticationError err
 --  , ToJSON               err -- TODO this is arguable
   , Exception              err
@@ -63,6 +65,7 @@ type GargServerC env err m =
   ( HasNodeStory env err m
   , HasMail      env
   , MonadRandom          m
+  , Safe.MonadCatch m
   , EnvC         env
   , ErrC             err
   , ToJSON           err

src/Gargantext/API/Routes/Client.hs

@@ -38,7 +38,7 @@ clientRoutes = genericClient
 
 remoteImportClient :: Auth.Token
                    -> C.ConduitT () Named.RemoteBinaryData IO ()
-                   -> ClientM (C.ConduitT () Named.RemoteBinaryData IO ())
+                   -> ClientM ()
 remoteImportClient (S.Token . TE.encodeUtf8 -> token) c =
   clientRoutes & apiWithCustomErrorScheme
                & ($ GES_new)

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

 
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DerivingStrategies #-}
 module Gargantext.API.Routes.Named.Remote (
   -- * Routes types
     RemoteAPI(..)
@@ -8,6 +9,7 @@ module Gargantext.API.Routes.Named.Remote (
   , RemoteBinaryData(..)
   ) where
 
+import Conduit qualified as C
 import Data.Aeson as JSON
 import Data.ByteString.Lazy qualified as BL
 import Data.ByteString qualified as BS
@@ -20,7 +22,6 @@ import Prelude
 import Servant.API
 import Servant.Client.Core.BaseUrl
 import Test.QuickCheck
-import qualified Conduit as C
 
 
 data RemoteAPI mode = RemoteAPI
@@ -77,5 +78,5 @@ instance ToSchema RemoteBinaryData where
 data RemoteAPI' mode = RemoteAPI'
   { remoteExportEp :: mode :- "export" :> ReqBody '[JSON] RemoteExportRequest :> Post '[JSON] ()
   , remoteImportEp :: mode :- "import" :> StreamBody NoFraming OctetStream (C.ConduitT () RemoteBinaryData IO ())
-                                       :> StreamPost NoFraming OctetStream (C.ConduitT () RemoteBinaryData IO ())
+                                       :> Post '[JSON] ()
   } deriving Generic

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

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Gargantext.API.Server.Named.Remote (
   remoteAPI
@@ -9,16 +10,21 @@ module Gargantext.API.Server.Named.Remote (
 
 import Codec.Serialise
 import Conduit
-import Control.Lens (view)
+import Control.Exception.Safe qualified as Safe
+import Control.Exception (toException)
+import Control.Lens (view, (#))
+import Control.Monad.Except (throwError)
 import Data.ByteString.Builder qualified as B
 import Data.ByteString.Char8 qualified as C8
 import Data.ByteString.Lazy qualified as BL
 import Data.Conduit.Combinators qualified as C
 import Data.Conduit.List qualified as CL
+import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude (IsGargServer)
 import Gargantext.API.Routes.Client (remoteImportClient)
 import Gargantext.API.Routes.Named.Remote qualified as Named
 import Gargantext.Core.Config
+import Gargantext.Database.Prelude (IsDBCmd)
 import Prelude
 import Servant.Client.Streaming (mkClientEnv, withClientM, ClientError)
 import Servant.Server.Generic (AsServerT)
@@ -27,19 +33,21 @@ remoteAPI :: (MonadIO m, IsGargServer env err m) => Named.RemoteAPI (AsServerT m
 remoteAPI = Named.RemoteAPI $
   Named.RemoteAPI'
     { remoteExportEp = remoteExportHandler
-    , remoteImportEp = pure
+    , remoteImportEp = remoteImportHandler
     }
 
 type ExpectedPayload = C8.ByteString -- FIXME(adn)
 
-remoteImportHandler :: (MonadIO m, Serialise a) => ConduitT () Named.RemoteBinaryData IO () -> m a
-remoteImportHandler c = liftIO $ do
-  chunks <- sourceToList $ c .| C.map (B.byteString . Named.getRemoteBinaryData)
-  case deserialiseOrFail (B.toLazyByteString $ mconcat chunks) of
-    Left err    -> liftIO $ error $ "Deserialization error: " ++ show err
-    Right value -> pure value
+remoteImportHandler :: (HasBackendInternalError err, IsDBCmd env err m, MonadIO m)
+                    => ConduitT () Named.RemoteBinaryData IO ()
+                    -> m ()
+remoteImportHandler c = do
+  chunks <- liftIO $ sourceToList $ c .| C.map (B.byteString . Named.getRemoteBinaryData)
+  case deserialiseOrFail @ExpectedPayload (B.toLazyByteString $ mconcat chunks) of
+    Left err    -> throwError $ _BackendInternalError # InternalUnexpectedError (toException $ userError $ "Deserialization error: " ++ show err)
+    Right value -> liftIO $ putStrLn $ show $ value
 
-remoteExportHandler :: ( MonadIO m
+remoteExportHandler :: ( MonadIO m, Safe.MonadCatch m
                        , IsGargServer err env m
                        )
                     => Named.RemoteExportRequest
@@ -48,13 +56,14 @@ remoteExportHandler Named.RemoteExportRequest{..} = do
   mgr  <- view gargHttpManager
   -- FIXME(adn) eventually we want to be sending nodes here.
   let node = C8.pack "hello world"
-  result <- liftIO $ withClientM (remoteImportClient _rer_instance_auth (streamEncoder node)) (mkClientEnv mgr _rer_instance_url) streamDecode
-  liftIO $ putStrLn (show (result :: ExpectedPayload))
+  liftIO (withClientM (remoteImportClient _rer_instance_auth (streamEncoder node)) (mkClientEnv mgr _rer_instance_url) streamDecode)
+              `Safe.catch` \(e :: BackendInternalError) -> throwError $ _BackendInternalError # e
 
-streamEncoder :: Serialise a => a -> ConduitT () Named.RemoteBinaryData IO ()
+streamEncoder :: (MonadIO m, Serialise a) => a -> ConduitT () Named.RemoteBinaryData m ()
 streamEncoder = CL.sourceList . map Named.RemoteBinaryData . BL.toChunks . serialise
 
-streamDecode :: Either ClientError (ConduitT () Named.RemoteBinaryData IO ()) -> IO ExpectedPayload
+-- | Returns a conduit which can be used to decode
+streamDecode :: Either ClientError () -> IO ()
 streamDecode = \case
-  Left err -> error $ show err -- FIXME(adn) How to deal with the error properly?
-  Right c  -> remoteImportHandler c
+  Left err -> Safe.throwIO $ InternalUnexpectedError (toException $ userError $ show err)
+  Right _  -> pure ()