Store extra info in federation client errors

libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs

@@ -27,7 +27,7 @@ import Servant.API.Generic
 import Servant.Client.Generic (AsClientT, genericClient)
 import Test.QuickCheck (Arbitrary)
 import Wire.API.Arbitrary (GenericUniform (..))
-import Wire.API.Federation.Client (FederationClientError, FederatorClient)
+import Wire.API.Federation.Client (FederationClientFailure, FederatorClient)
 import qualified Wire.API.Federation.GRPC.Types as Proto
 import Wire.API.Message (UserClients)
 import Wire.API.User (UserProfile)
@@ -86,5 +86,5 @@ data Api routes = Api
   }
   deriving (Generic)
 
-clientRoutes :: (MonadError FederationClientError m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Brig m))
+clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Brig m))
 clientRoutes = genericClient

libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs

@@ -29,7 +29,7 @@ import Servant.Client.Generic (AsClientT, genericClient)
 import Wire.API.Arbitrary (Arbitrary, GenericUniform (..))
 import Wire.API.Conversation (Conversation)
 import Wire.API.Conversation.Role (RoleName)
-import Wire.API.Federation.Client (FederationClientError, FederatorClient)
+import Wire.API.Federation.Client (FederationClientFailure, FederatorClient)
 import qualified Wire.API.Federation.GRPC.Types as Proto
 import Wire.API.Federation.Util.Aeson (CustomEncoded (CustomEncoded))
 
@@ -82,5 +82,5 @@ data ConversationMemberUpdate = ConversationMemberUpdate
   deriving (Arbitrary) via (GenericUniform ConversationMemberUpdate)
   deriving (ToJSON, FromJSON) via (CustomEncoded ConversationMemberUpdate)
 
-clientRoutes :: (MonadError FederationClientError m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Galley m))
+clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Galley m))
 clientRoutes = genericClient

libs/wire-api-federation/src/Wire/API/Federation/Client.hs

@@ -21,6 +21,7 @@
 module Wire.API.Federation.Client where
 
 import Control.Monad.Except (ExceptT, MonadError (..), withExceptT)
+import Control.Monad.State (MonadState (..), StateT, evalStateT, gets)
 import Data.ByteString.Builder (toLazyByteString)
 import qualified Data.ByteString.Lazy as LBS
 import Data.Domain (Domain, domainText)
@@ -41,11 +42,11 @@ data FederatorClientEnv = FederatorClientEnv
     originDomain :: Domain
   }
 
-newtype FederatorClient (component :: Proto.Component) m a = FederatorClient {runFederatorClient :: ReaderT FederatorClientEnv m a}
-  deriving newtype (Functor, Applicative, Monad, MonadReader FederatorClientEnv, MonadIO)
+newtype FederatorClient (component :: Proto.Component) m a = FederatorClient {runFederatorClient :: ReaderT FederatorClientEnv (StateT (Maybe ByteString) m) a}
+  deriving newtype (Functor, Applicative, Monad, MonadReader FederatorClientEnv, MonadState (Maybe ByteString), MonadIO)
 
-runFederatorClientWith :: GrpcClient -> Domain -> Domain -> FederatorClient component m a -> m a
-runFederatorClientWith client targetDomain originDomain = flip runReaderT (FederatorClientEnv client targetDomain originDomain) . runFederatorClient
+runFederatorClientWith :: Monad m => GrpcClient -> Domain -> Domain -> FederatorClient component m a -> m a
+runFederatorClientWith client targetDomain originDomain = flip evalStateT Nothing . flip runReaderT (FederatorClientEnv client targetDomain originDomain) . runFederatorClient
 
 class KnownComponent (c :: Proto.Component) where
   componentVal :: Proto.Component
@@ -58,26 +59,37 @@ instance KnownComponent 'Proto.Galley where
 
 -- | expectedStatuses is ignored as we don't get any status from the federator,
 -- all responses have '200 OK' as their status.
-instance (Monad m, MonadError FederationClientError m, MonadIO m, KnownComponent component) => RunClient (FederatorClient component m) where
+instance (Monad m, MonadIO m, MonadError FederationClientFailure m, KnownComponent component) => RunClient (FederatorClient component m) where
   runRequestAcceptStatus _expectedStatuses req = do
     env <- ask
+    let path = LBS.toStrict . toLazyByteString $ requestPath req
+        domain = targetDomain env
+        mkFailure = FederationClientFailure domain path
+        failure :: MonadError FederationClientFailure n => FederationClientError -> n x
+        failure = throwError . mkFailure
+        rpcFailure = failure . FederationClientRPCError
+        readBody = \case
+          RequestBodyLBS lbs -> pure $ LBS.toStrict lbs
+          RequestBodyBS bs -> pure bs
+          RequestBodySource _ -> failure FederationClientStreamingUnsupported
+    put (Just path)
     body <- readBody . maybe (RequestBodyBS "") fst $ requestBody req
     let call =
           Proto.ValidatedFederatedRequest
-            (targetDomain env)
+            domain
             ( Proto.Request
                 (componentVal @component)
-                (LBS.toStrict . toLazyByteString $ requestPath req)
+                path
                 body
                 (domainText (originDomain env))
             )
     grpcResponse <- callRemote (grpcClient env) call
     case grpcResponse of
-      GRpcTooMuchConcurrency _tmc -> rpcErr "too much concurrency"
-      GRpcErrorCode code -> rpcErr $ "grpc error code: " <> T.pack (show code)
-      GRpcErrorString msg -> rpcErr $ "grpc error: " <> T.pack msg
-      GRpcClientError msg -> rpcErr $ "grpc client error: " <> T.pack (show msg)
-      GRpcOk (Proto.OutwardResponseError err) -> throwError (FederationClientOutwardError err)
+      GRpcTooMuchConcurrency _tmc -> rpcFailure "too much concurrency"
+      GRpcErrorCode code -> rpcFailure $ "grpc error code: " <> T.pack (show code)
+      GRpcErrorString msg -> rpcFailure $ "grpc error: " <> T.pack msg
+      GRpcClientError msg -> rpcFailure $ "grpc client error: " <> T.pack (show msg)
+      GRpcOk (Proto.OutwardResponseError err) -> failure (FederationClientOutwardError err)
       GRpcOk (Proto.OutwardResponseBody res) -> do
         pure $
           Response
@@ -89,23 +101,28 @@ instance (Monad m, MonadError FederationClientError m, MonadIO m, KnownComponent
               responseHttpVersion = HTTP.http11,
               responseBody = LBS.fromStrict res
             }
-    where
-      rpcErr = throwError . FederationClientRPCError
-      readBody = \case
-        RequestBodyLBS lbs -> pure $ LBS.toStrict lbs
-        RequestBodyBS bs -> pure bs
-        RequestBodySource _ -> throwError FederationClientStreamingUnsupported
-  throwClientError = throwError . FederationClientServantError
-
-instance (Monad m, MonadError FederationClientError m) => MonadError FederationClientError (FederatorClient c m) where
+
+  throwClientError err = do
+    dom <- asks targetDomain
+    path <- gets (fromMaybe "")
+    throwError (FederationClientFailure dom path (FederationClientServantError err))
+
+instance (Monad m, MonadError FederationClientFailure m) => MonadError FederationClientFailure (FederatorClient c m) where
   throwError = FederatorClient . throwError
   catchError (FederatorClient action) f = FederatorClient $ catchError action (runFederatorClient . f)
 
 data FederationError
   = FederationUnavailable Text
   | FederationNotImplemented
   | FederationNotConfigured
-  | FederationCallFailure FederationClientError
+  | FederationCallFailure FederationClientFailure
+
+data FederationClientFailure = FederationClientFailure
+  { fedFailDomain :: Domain,
+    fedFailPath :: ByteString,
+    fedFailError :: FederationClientError
+  }
+  deriving (Show, Eq)
 
 data FederationClientError
   = FederationClientInvalidMethod HTTP.Method
@@ -141,7 +158,7 @@ mkFederatorClient = do
 executeFederated ::
   (MonadIO m, HasFederatorConfig m) =>
   Domain ->
-  FederatorClient component (ExceptT FederationClientError m) a ->
+  FederatorClient component (ExceptT FederationClientFailure m) a ->
   ExceptT FederationError m a
 executeFederated targetDomain action = do
   federatorClient <- mkFederatorClient

libs/wire-api-federation/src/Wire/API/Federation/Error.hs

@@ -25,15 +25,19 @@ import Network.HTTP.Types.Status
 import qualified Network.HTTP.Types.Status as HTTP
 import qualified Network.Wai.Utilities.Error as Wai
 import qualified Servant.Client as Servant
-import Wire.API.Federation.Client (FederationClientError (..), FederationError (..))
+import Wire.API.Federation.Client
+  ( FederationClientError (..),
+    FederationClientFailure (..),
+    FederationError (..),
+  )
 import qualified Wire.API.Federation.GRPC.Types as Proto
 
 federationErrorToWai :: FederationError -> Wai.Error
 federationErrorToWai (FederationUnavailable err) = federationUnavailable err
 federationErrorToWai FederationNotImplemented = federationNotImplemented
 federationErrorToWai FederationNotConfigured = federationNotConfigured
-federationErrorToWai (FederationCallFailure err) =
-  case err of
+federationErrorToWai (FederationCallFailure failure) =
+  case fedFailError failure of
     FederationClientRPCError msg -> federationRpcError msg
     FederationClientInvalidMethod mth ->
       federationInvalidCall

libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs

@@ -22,6 +22,7 @@ module Test.Wire.API.Federation.ClientSpec where
 
 import Control.Monad.Except (ExceptT, MonadError (..), runExceptT)
 import qualified Data.Aeson as Aeson
+import Data.Bifunctor (first)
 import qualified Data.ByteString.Lazy as LBS
 import Data.Domain (Domain (Domain))
 import qualified Data.Text as Text
@@ -30,7 +31,7 @@ import qualified Mu.Server as Mu
 import Test.Hspec
 import Test.QuickCheck (arbitrary, generate)
 import qualified Wire.API.Federation.API.Brig as Brig
-import Wire.API.Federation.Client (FederationClientError (FederationClientOutwardError, FederationClientRPCError))
+import Wire.API.Federation.Client (FederationClientError (FederationClientOutwardError, FederationClientRPCError), FederationClientFailure (..))
 import Wire.API.Federation.GRPC.Types (Component (Brig), FederatedRequest (FederatedRequest), Request (..))
 import Wire.API.Federation.Mock
 import Wire.API.User (UserProfile)
@@ -63,7 +64,8 @@ spec = do
           assertRightT . withMockFederatorClient stateRef (mkErrorResponse someErr) $
             Brig.getUserByHandle Brig.clientRoutes handle
 
-        actualResponse `shouldBe` Left (FederationClientOutwardError someErr)
+        first fedFailError actualResponse
+          `shouldBe` Left (FederationClientOutwardError someErr)
 
       it "should report federator failures correctly" $ do
         handle <- generate arbitrary
@@ -75,10 +77,10 @@ spec = do
         case actualResponse of
           Right res ->
             expectationFailure $ "Expected response to be failure, got: \n" <> show res
-          Left (FederationClientRPCError errText) ->
+          Left (FederationClientFailure _ _ (FederationClientRPCError errText)) ->
             Text.unpack errText `shouldStartWith` "grpc error: GRPC status indicates failure: status-code=INTERNAL, status-message=\"some IO error!"
           Left err ->
-            expectationFailure $ "Expected FedeartionClientRPCError, got different error: \n" <> show err
+            expectationFailure $ "Expected FederationClientRPCError, got different error: \n" <> show err
 
       it "should report GRPC errors correctly" $ do
         handle <- generate arbitrary
@@ -87,7 +89,8 @@ spec = do
           assertRightT . withMockFederatorClient stateRef (throwError $ Mu.ServerError Mu.NotFound "Just testing") $
             Brig.getUserByHandle Brig.clientRoutes handle
 
-        actualResponse `shouldBe` Left (FederationClientRPCError "grpc error: GRPC status indicates failure: status-code=NOT_FOUND, status-message=\"Just testing\"")
+        first fedFailError actualResponse
+          `shouldBe` Left (FederationClientRPCError "grpc error: GRPC status indicates failure: status-code=NOT_FOUND, status-message=\"Just testing\"")
 
 assertRight :: Either String b -> IO b
 assertRight = \case