Add more information to federation errors

libs/wai-utilities/src/Network/Wai/Utilities/Error.hs

@@ -18,40 +18,78 @@
 -- You should have received a copy of the GNU Affero General Public License along
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
-module Network.Wai.Utilities.Error where
+module Network.Wai.Utilities.Error
+  ( Error (..),
+    ErrorData (..),
+    mkError,
+    (!>>),
+    byteStringError,
+  )
+where
 
 import Control.Error
 import Data.Aeson hiding (Error)
+import Data.Aeson.Types (Pair)
+import Data.Domain
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Imports
 import Network.HTTP.Types
 
 data Error = Error
   { code :: !Status,
     label :: !LText,
-    message :: !LText
+    message :: !LText,
+    errorData :: Maybe ErrorData
   }
   deriving (Show, Typeable)
 
+mkError :: Status -> LText -> LText -> Error
+mkError c l m = Error c l m Nothing
+
 instance Exception Error
 
+data ErrorData = FederationErrorData
+  { federrDomain :: !Domain,
+    federrPath :: !Text
+  }
+  deriving (Show, Typeable)
+
+instance ToJSON ErrorData where
+  toJSON (FederationErrorData d p) =
+    object
+      [ "type" .= ("federation" :: Text),
+        "domain" .= d,
+        "path" .= p
+      ]
+
+instance FromJSON ErrorData where
+  parseJSON = withObject "ErrorData" $ \o ->
+    FederationErrorData
+      <$> o .: "domain"
+      <*> o .: "path"
+
 -- | Assumes UTF-8 encoding.
 byteStringError :: Status -> LByteString -> LByteString -> Error
-byteStringError s l m = Error s (decodeUtf8 l) (decodeUtf8 m)
+byteStringError s l m = Error s (decodeUtf8 l) (decodeUtf8 m) Nothing
 
 instance ToJSON Error where
-  toJSON (Error c l m) =
-    object
+  toJSON (Error c l m md) =
+    object $
       [ "code" .= statusCode c,
         "label" .= l,
         "message" .= m
       ]
+        ++ fromMaybe [] (fmap dataFields md)
+    where
+      dataFields :: ErrorData -> [Pair]
+      dataFields d = ["data" .= d]
 
 instance FromJSON Error where
   parseJSON = withObject "Error" $ \o ->
     Error <$> (toEnum <$> o .: "code")
       <*> o .: "label"
       <*> o .: "message"
+      <*> o .:? "data"
 
 -- FIXME: This should not live here.
 infixl 5 !>>

libs/wai-utilities/src/Network/Wai/Utilities/Request.hs

@@ -56,7 +56,7 @@ parseBody r = readBody r >>= hoistEither . fmapL Text.pack . eitherDecode'
 parseBody' :: (FromJSON a, MonadIO m, MonadThrow m) => JsonRequest a -> m a
 parseBody' r = either thrw pure =<< runExceptT (parseBody r)
   where
-    thrw msg = throwM $ Wai.Error status400 "bad-request" msg
+    thrw msg = throwM $ Wai.mkError status400 "bad-request" msg
 
 parseOptionalBody ::
   (MonadIO m, FromJSON a) =>

libs/wai-utilities/src/Network/Wai/Utilities/Response.hs

@@ -46,7 +46,7 @@ jsonContent :: Header
 jsonContent = (hContentType, "application/json")
 
 errorRs :: Status -> LText -> LText -> Response
-errorRs s l m = errorRs' (Error s l m)
+errorRs s l m = errorRs' (mkError s l m)
 
 errorRs' :: Error -> Response
 errorRs' e = setStatus (code e) (json e)

libs/wai-utilities/src/Network/Wai/Utilities/Server.hs

@@ -54,6 +54,7 @@ import qualified Data.ByteString as BS
 import Data.ByteString.Builder
 import qualified Data.ByteString.Char8 as C
 import qualified Data.ByteString.Lazy as LBS
+import Data.Domain (domainText)
 import Data.Metrics.GC (spawnGCMetricsCollector)
 import Data.Metrics.Middleware
 import Data.Streaming.Zlib (ZlibException (..))
@@ -145,7 +146,7 @@ runSettingsWithShutdown s app secs = do
 compile :: Monad m => Routes a m b -> Tree (App m)
 compile routes = Route.prepare (Route.renderer predicateError >> routes)
   where
-    predicateError e = return (encode $ Wai.Error (P.status e) "client-error" (format e), [jsonContent])
+    predicateError e = return (encode $ Wai.mkError (P.status e) "client-error" (format e), [jsonContent])
     -- [label] 'source' reason: message
     format e =
       let l = labelStr $ labels e
@@ -171,7 +172,7 @@ compile routes = Route.prepare (Route.renderer predicateError >> routes)
 route :: (MonadCatch m, MonadIO m) => Tree (App m) -> Request -> Continue IO -> m ResponseReceived
 route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (liftIO . k)
   where
-    noEndpoint = Wai.Error status404 "no-endpoint" "The requested endpoint does not exist"
+    noEndpoint = Wai.mkError status404 "no-endpoint" "The requested endpoint does not exist"
 {-# INLINEABLE route #-}
 
 --------------------------------------------------------------------------------
@@ -201,12 +202,12 @@ catchErrors l m app req k =
 errorHandlers :: Applicative m => [Handler m Wai.Error]
 errorHandlers =
   [ Handler $ \(x :: Wai.Error) -> pure x,
-    Handler $ \(_ :: InvalidRequest) -> pure $ Wai.Error status400 "client-error" "Invalid Request",
-    Handler $ \(_ :: TimeoutThread) -> pure $ Wai.Error status408 "client-error" "Request Timeout",
+    Handler $ \(_ :: InvalidRequest) -> pure $ Wai.mkError status400 "client-error" "Invalid Request",
+    Handler $ \(_ :: TimeoutThread) -> pure $ Wai.mkError status408 "client-error" "Request Timeout",
     Handler $ \case
-      ZlibException (-3) -> pure $ Wai.Error status400 "client-error" "Invalid request body compression"
-      ZlibException _ -> pure $ Wai.Error status500 "server-error" "Server Error",
-    Handler $ \(_ :: SomeException) -> pure $ Wai.Error status500 "server-error" "Server Error"
+      ZlibException (-3) -> pure $ Wai.mkError status400 "client-error" "Invalid request body compression"
+      ZlibException _ -> pure $ Wai.mkError status500 "server-error" "Server Error",
+    Handler $ \(_ :: SomeException) -> pure $ Wai.mkError status500 "server-error" "Server Error"
   ]
 {-# INLINE errorHandlers #-}
 
@@ -298,7 +299,7 @@ rethrow5xx logger app req k = app req k'
         then k resp
         else do
           rsbody :: LText <- liftIO $ cs <$> lazyResponseBody resp
-          throwM $ Wai.Error st "server-error" rsbody
+          throwM $ Wai.mkError st "server-error" rsbody
 
 -- | This flushes the response!  If you want to keep using the response, you need to construct
 -- a new one with a fresh body stream.
@@ -342,14 +343,20 @@ logError :: (MonadIO m, HasRequest r) => Logger -> Maybe r -> Wai.Error -> m ()
 logError g mr = logError' g (lookupRequestId =<< mr)
 
 logError' :: (MonadIO m) => Logger -> Maybe ByteString -> Wai.Error -> m ()
-logError' g mr (Wai.Error c l m) = liftIO $ Log.debug g logMsg
+logError' g mr (Wai.Error c l m md) = liftIO $ Log.debug g logMsg
   where
     logMsg =
       field "code" (statusCode c)
         . field "label" l
         . field "request" (fromMaybe "N/A" mr)
+        . fromMaybe id (fmap logErrorData md)
         . msg (val "\"" +++ m +++ val "\"")
 
+    -- TODO: actually log error data fields
+    logErrorData (Wai.FederationErrorData d p) =
+      field "domain" (domainText d)
+        . field "path" p
+
 logIO :: (ToBytes msg, HasRequest r) => Logger -> Level -> Maybe r -> msg -> IO ()
 logIO lg lv r a =
   let reqId = field "request" . fromMaybe "N/A" . lookupRequestId <$> r

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