Federation error wrapping

changelog.d/1-api-changes/fed-error-wrapping

@@ -0,0 +1 @@
+Improved formatting of federation errors. No extra copy of the response body, and nested errors are now part of the JSON structure, not quoted inside the message.

integration/default.nix

@@ -53,6 +53,7 @@
 , scientific
 , split
 , stm
+, streaming-commons
 , string-conversions
 , tagged
 , temporary
@@ -64,6 +65,9 @@
 , unliftio
 , uuid
 , vector
+, wai
+, warp
+, warp-tls
 , websockets
 , wire-message-proto-lens
 , xml
@@ -124,6 +128,7 @@ mkDerivation {
     scientific
     split
     stm
+    streaming-commons
     string-conversions
     tagged
     temporary
@@ -135,6 +140,9 @@ mkDerivation {
     unliftio
     uuid
     vector
+    wai
+    warp
+    warp-tls
     websockets
     wire-message-proto-lens
     xml

integration/integration.cabal

@@ -108,6 +108,7 @@ library
     Test.Client
     Test.Conversation
     Test.Demo
+    Test.Errors
     Test.Federation
     Test.Federator
     Test.MessageTimer
@@ -128,6 +129,7 @@ library
     Testlib.Env
     Testlib.HTTP
     Testlib.JSON
+    Testlib.Mock
     Testlib.ModService
     Testlib.One2One
     Testlib.Options
@@ -190,6 +192,7 @@ library
     , scientific
     , split
     , stm
+    , streaming-commons
     , string-conversions
     , tagged
     , temporary
@@ -201,6 +204,9 @@ library
     , unliftio
     , uuid
     , vector
+    , wai
+    , warp
+    , warp-tls
     , websockets
     , wire-message-proto-lens
     , xml

integration/test/Test/Errors.hs

@@ -0,0 +1,54 @@
+{-# OPTIONS -Wno-ambiguous-fields #-}
+module Test.Errors where
+
+import API.Brig
+import Control.Monad.Codensity
+import Control.Monad.Reader
+import Data.Aeson qualified as Aeson
+import Network.HTTP.Types qualified as HTTP
+import Network.Wai qualified as Wai
+import SetupHelpers
+import Testlib.Mock
+import Testlib.Prelude
+import Testlib.ResourcePool
+
+testNestedError :: HasCallStack => App ()
+testNestedError = do
+  let innerError =
+        object
+          [ "code" .= (400 :: Int),
+            "label" .= "example",
+            "message" .= "Example remote federator failure"
+          ]
+
+  resourcePool <- asks resourcePool
+  lowerCodensity $ do
+    [res] <- acquireResources 1 resourcePool
+    mockConfig <- do
+      mBase <- asks (.servicesCwdBase)
+      pure $ case mBase of
+        Just _ ->
+          -- when running locally, spawn a fake ingress returning an error
+          def
+            { port = Just (fromIntegral res.berNginzSslPort),
+              tls = True
+            }
+        Nothing -> do
+          -- on CI, the real federation ingress is available, so we spawn its federator upstream instead
+          def
+            { port = Just (fromIntegral res.berFederatorExternal),
+              tls = False
+            }
+    void $
+      startMockServer mockConfig $
+        codensityApp $
+          \_req -> pure $ Wai.responseLBS HTTP.status400 mempty $ Aeson.encode innerError
+
+    -- get remote user
+    lift $ do
+      user <- randomUser OwnDomain def
+      targetId <- randomId
+      let target = object ["id" .= targetId, "domain" .= res.berDomain]
+      bindResponse (getUser user target) $ \resp -> do
+        resp.status `shouldMatchInt` 533
+        resp.json %. "inner" `shouldMatch` innerError

integration/test/Testlib/Mock.hs

@@ -0,0 +1,85 @@
+module Testlib.Mock (startMockServer, MockServerConfig (..), codensityApp) where
+
+import Control.Concurrent.Async
+import Control.Concurrent.MVar
+import Control.Exception
+import Control.Monad.Codensity
+import Control.Monad.Reader
+import Data.Streaming.Network
+import Network.Socket qualified as Socket
+import Network.Wai qualified as Wai
+import Network.Wai.Handler.Warp qualified as Warp
+import Network.Wai.Handler.WarpTLS qualified as Warp
+import Testlib.Prelude
+
+codensityApp :: (Wai.Request -> Codensity IO Wai.Response) -> Wai.Application
+codensityApp f req = runCodensity (f req)
+
+data MockServerConfig = MockServerConfig
+  { port :: Maybe Warp.Port,
+    tls :: Bool
+  }
+
+instance Default MockServerConfig where
+  def = MockServerConfig {port = Nothing, tls = False}
+
+spawnServer :: Warp.Settings -> Socket.Socket -> Wai.Application -> App ()
+spawnServer wsettings sock app = liftIO $ Warp.runSettingsSocket wsettings sock app
+
+spawnTLSServer :: Warp.Settings -> Socket.Socket -> Wai.Application -> App ()
+spawnTLSServer wsettings sock app = do
+  (cert, key) <-
+    asks (.servicesCwdBase) <&> \case
+      Nothing ->
+        ( "/etc/wire/federator/secrets/tls.crt",
+          "/etc/wire/federator/secrets/tls.key"
+        )
+      Just base ->
+        ( base <> "/federator/test/resources/integration-leaf.pem",
+          base <> "/federator/test/resources/integration-leaf-key.pem"
+        )
+  liftIO $ Warp.runTLSSocket (Warp.tlsSettings cert key) wsettings sock app
+
+startMockServer :: MockServerConfig -> Wai.Application -> Codensity App Warp.Port
+startMockServer config app = do
+  let closeSocket sock = catch (Socket.close sock) (\(_ :: SomeException) -> pure ())
+  (port, sock) <- Codensity $ \k -> do
+    action <- appToIOKleisli k
+    liftIO $
+      bracket
+        ( case config.port of
+            Nothing -> bindRandomPortTCP (fromString "*6")
+            Just n -> (n,) <$> bindPortTCP n (fromString "*6")
+        )
+        (\(_, sock) -> closeSocket sock)
+        action
+  serverStarted <- liftIO newEmptyMVar
+  let wsettings =
+        Warp.defaultSettings
+          & Warp.setPort port
+          & Warp.setGracefulCloseTimeout2 0
+          & Warp.setBeforeMainLoop (putMVar serverStarted Nothing)
+
+  -- Action to start server in a separate thread.
+  startServer <- lift . appToIO $ (if config.tls then spawnTLSServer else spawnServer) wsettings sock app
+  let startServerAsync = do
+        a <- async $ do
+          catch startServer $ \(e :: SomeException) ->
+            void $ tryPutMVar serverStarted (Just e)
+        mException <- readMVar serverStarted
+        traverse_ throw mException
+        pure a
+
+  Codensity $ \k -> do
+    action <- appToIO (k ())
+    liftIO
+      $ bracket
+        startServerAsync
+        ( \serverAsync -> do
+            closeSocket sock
+            -- kill the thread running the server
+            cancel serverAsync
+        )
+      $ const action
+
+  pure port

integration/test/Testlib/ModService.hs

@@ -18,7 +18,6 @@ import Control.Monad.Extra
 import Control.Monad.Reader
 import Control.Retry (fibonacciBackoff, limitRetriesByCumulativeDelay, retrying)
 import Data.Aeson hiding ((.=))
-import Data.Aeson.KeyMap qualified as Aeson
 import Data.Default
 import Data.Foldable
 import Data.Function
@@ -355,19 +354,15 @@ startBackend resource overrides services = do
                   . (addJSONObject [])
             checkStatus <- appToIO $ do
               res <- submit "POST" req
-              -- If we get 533 here it means federation is not avaiable between domains
+              -- If we get 533 here it means federation is not available between domains
               -- but ingress is working, since we're processing the request.
               let is200 = res.status == 200
-                  msg = case res.jsonBody of
-                    Just (Object obj) ->
-                      (Aeson.lookup "message" obj)
-                    _ -> Nothing
-                  isFedDenied =
-                    res.status == 533
-                      && ( Text.isInfixOf
-                             "federation-denied"
-                             (Text.pack $ show msg)
-                         )
+              mInner <- lookupField res.json "inner"
+              isFedDenied <- case mInner of
+                Nothing -> pure False
+                Just inner -> do
+                  label <- inner %. "label" & asString
+                  pure $ res.status == 533 && label == "federation-denied"
 
               pure (is200 || isFedDenied)
             eith <- liftIO (E.try checkStatus)

integration/test/Testlib/ResourcePool.hs

@@ -2,7 +2,6 @@ module Testlib.ResourcePool
   ( ResourcePool,
     BackendResource (..),
     DynamicBackendConfig (..),
-    backendResources,
     createBackendResourcePool,
     acquireResources,
     backendA,

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

@@ -31,58 +31,57 @@ import Control.Error
 import Data.Aeson hiding (Error)
 import Data.Aeson.Types (Pair)
 import Data.Domain
-import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
+import Data.Text.Lazy.Encoding (decodeUtf8)
 import Imports
 import Network.HTTP.Types
 
 data Error = Error
   { code :: !Status,
     label :: !LText,
     message :: !LText,
-    errorData :: Maybe ErrorData
+    errorData :: Maybe ErrorData,
+    innerError :: Maybe Error
   }
   deriving (Eq, Show, Typeable)
 
 mkError :: Status -> LText -> LText -> Error
-mkError c l m = Error c l m Nothing
+mkError c l m = Error c l m Nothing Nothing
 
 instance Exception Error
 
 data ErrorData = FederationErrorData
   { federrDomain :: !Domain,
-    federrPath :: !Text,
-    federrResp :: !(Maybe LByteString)
+    federrPath :: !Text
   }
   deriving (Eq, Show, Typeable)
 
 instance ToJSON ErrorData where
-  toJSON (FederationErrorData d p b) =
-    object
+  toJSON (FederationErrorData d p) =
+    object $
       [ "type" .= ("federation" :: Text),
         "domain" .= d,
-        "path" .= p,
-        "response" .= fmap decodeUtf8 b
+        "path" .= p
       ]
 
 instance FromJSON ErrorData where
   parseJSON = withObject "ErrorData" $ \o ->
     FederationErrorData
       <$> o .: "domain"
       <*> o .: "path"
-      <*> (fmap encodeUtf8 <$> (o .: "response"))
 
 -- | Assumes UTF-8 encoding.
 byteStringError :: Status -> LByteString -> LByteString -> Error
-byteStringError s l m = Error s (decodeUtf8 l) (decodeUtf8 m) Nothing
+byteStringError s l m = mkError s (decodeUtf8 l) (decodeUtf8 m)
 
 instance ToJSON Error where
-  toJSON (Error c l m md) =
+  toJSON (Error c l m md inner) =
     object $
       [ "code" .= statusCode c,
         "label" .= l,
         "message" .= m
       ]
         ++ maybe [] dataFields md
+        ++ ["inner" .= e | e <- toList inner]
     where
       dataFields :: ErrorData -> [Pair]
       dataFields d = ["data" .= d]
@@ -94,6 +93,7 @@ instance FromJSON Error where
       <*> o .: "label"
       <*> o .: "message"
       <*> o .:? "data"
+      <*> o .:? "inner"
 
 -- FIXME: This should not live here.
 infixl 5 !>>

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

@@ -392,16 +392,16 @@ logJSONResponse g mr e = do
       | otherwise = Log.debug
 
 logErrorMsg :: Wai.Error -> Msg -> Msg
-logErrorMsg (Wai.Error c l m md) =
+logErrorMsg (Wai.Error c l m md inner) =
   field "code" (statusCode c)
     . field "label" l
     . maybe id logErrorData md
     . msg (val "\"" +++ m +++ val "\"")
+    . maybe id logErrorMsg inner
   where
-    logErrorData (Wai.FederationErrorData d p b) =
+    logErrorData (Wai.FederationErrorData d p) =
       field "domain" (domainText d)
         . field "path" p
-        . field "response" (fromMaybe "" b)
 
 logErrorMsgWithRequest :: Maybe ByteString -> Wai.Error -> Msg -> Msg
 logErrorMsgWithRequest mr e =

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

@@ -270,8 +270,7 @@ mkFailureResponse status domain path body
                 { Wai.federrDomain = domain,
                   Wai.federrPath =
                     "/federation"
-                      <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path),
-                  Wai.federrResp = pure body
+                      <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path)
                 }
         }
   where