Turn UnreachableBackends response into a Polysemy error (#3486)

* Add unreachable backend test * Revert "list unavailable backends as JSON in fed errors (#3407)" This reverts commit 1d776e0. * Simplify UnreachableBackends error handling * Remove unreachable case from Create response * Handle unreachable backends when checking fed status * Remove unused unreachable backend case in fed API --------- Co-authored-by: Marko Dimjašević <[email protected]>
wireapp · Aug 14, 2023 · e3dbd56 · e3dbd56
1 parent fd634bb
commit e3dbd56
Show file tree

Hide file tree

Showing 25 changed files with 349 additions and 381 deletions.
diff --git a/changelog.d/1-api-changes/WPB-3640 b/changelog.d/1-api-changes/WPB-3640
@@ -0,0 +1 @@
+Conversation creation endpoints can now return `unreachable_backends` error responses with status code 503 if any of the involved backends are unreachable. The conversation is not created in that case.
diff --git a/integration/test/Test/Conversation.hs b/integration/test/Test/Conversation.hs
@@ -51,8 +51,8 @@ testDynamicBackendsNotFederating = do
         $ bindResponse
           (getFederationStatus uidA [domainB, domainC])
         $ \resp -> do
-          resp.status `shouldMatchInt` 422
-          resp.json %. "label" `shouldMatch` "federation-denied"
+          resp.status `shouldMatchInt` 503
+          resp.json %. "unreachable_backends" `shouldMatchSet` [domainB, domainC]
 
 testDynamicBackendsFullyConnectedWhenAllowDynamic :: HasCallStack => App ()
 testDynamicBackendsFullyConnectedWhenAllowDynamic = do
@@ -123,8 +123,8 @@ testFederationStatus = do
   bindResponse
     (getFederationStatus uid [invalidDomain])
     $ \resp -> do
-      resp.status `shouldMatchInt` 422
-      resp.json %. "label" `shouldMatch` "invalid-domain"
+      resp.status `shouldMatchInt` 503
+      resp.json %. "unreachable_backends" `shouldMatchSet` [invalidDomain]
 
   bindResponse
     (getFederationStatus uid [federatingRemoteDomain])
@@ -327,3 +327,24 @@ testAddMembersNonFullyConnectedProteus = do
     bindResponse (addMembers u1 cid members) $ \resp -> do
       resp.status `shouldMatchInt` 409
       resp.json %. "non_federating_backends" `shouldMatchSet` [domainB, domainC]
+
+testConvWithUnreachableRemoteUsers :: App ()
+testConvWithUnreachableRemoteUsers = do
+  let overrides =
+        def {dbBrig = setField "optSettings.setFederationStrategy" "allowAll"}
+          <> fullSearchWithAll
+  ([alice, alex, bob, charlie, dylan], domains) <-
+    startDynamicBackends [overrides, overrides] $ \domains -> do
+      own <- make OwnDomain & asString
+      other <- make OtherDomain & asString
+      users <- createAndConnectUsers $ [own, own, other] <> domains
+      pure (users, domains)
+
+  let newConv = defProteus {qualifiedUsers = [alex, bob, charlie, dylan]}
+  bindResponse (postConversation alice newConv) $ \resp -> do
+    resp.status `shouldMatchInt` 503
+    resp.json %. "unreachable_backends" `shouldMatchSet` domains
+
+  convs <- getAllConvs alice >>= asList
+  regConvs <- filterM (\c -> (==) <$> (c %. "type" & asInt) <*> pure 0) convs
+  regConvs `shouldMatch` ([] :: [Value])
diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs
@@ -31,8 +31,6 @@ import Control.Error
 import Data.Aeson hiding (Error)
 import Data.Aeson.Types (Pair)
 import Data.Domain
-import Data.List.NonEmpty (NonEmpty)
-import Data.List.NonEmpty qualified as NE
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Imports
 import Network.HTTP.Types
@@ -51,24 +49,23 @@ mkError c l m = Error c l m Nothing
 instance Exception Error
 
 data ErrorData = FederationErrorData
-  { federrDomains :: NonEmpty Domain,
+  { federrDomain :: !Domain,
     federrPath :: !Text
   }
   deriving (Eq, Show, Typeable)
 
 instance ToJSON ErrorData where
-  toJSON (FederationErrorData ds p) =
+  toJSON (FederationErrorData d p) =
     object
       [ "type" .= ("federation" :: Text),
-        "domain" .= NE.head ds, -- deprecated in favour for `domains`
-        "domains" .= ds,
+        "domain" .= d,
         "path" .= p
       ]
 
 instance FromJSON ErrorData where
   parseJSON = withObject "ErrorData" $ \o ->
     FederationErrorData
-      <$> o .: "domains"
+      <$> o .: "domain"
       <*> o .: "path"
 
 -- | Assumes UTF-8 encoding.

diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs
@@ -57,11 +57,9 @@ import Data.ByteString.Builder
 import Data.ByteString.Char8 qualified as C
 import Data.ByteString.Lazy qualified as LBS
 import Data.Domain (domainText)
-import Data.List.NonEmpty qualified as NE
 import Data.Metrics.GC (spawnGCMetricsCollector)
 import Data.Metrics.Middleware
 import Data.Streaming.Zlib (ZlibException (..))
-import Data.Text qualified as T
 import Data.Text.Encoding.Error (lenientDecode)
 import Data.Text.Lazy.Encoding qualified as LT
 import Imports
@@ -400,13 +398,8 @@ logErrorMsg (Wai.Error c l m md) =
     . maybe id logErrorData md
     . msg (val "\"" +++ m +++ val "\"")
   where
-    logErrorData (Wai.FederationErrorData (NE.toList -> d) p) =
-      field
-        "domains"
-        ( val "["
-            +++ T.intercalate ", " (map domainText d)
-            +++ val "]"
-        )
+    logErrorData (Wai.FederationErrorData d p) =
+      field "domain" (domainText d)
         . field "path" p
 
 logErrorMsgWithRequest :: Maybe ByteString -> Wai.Error -> Msg -> Msg

diff --git a/libs/wire-api-federation/default.nix b/libs/wire-api-federation/default.nix
@@ -26,7 +26,6 @@
 , lib
 , metrics-wai
 , mtl
-, polysemy
 , QuickCheck
 , schema-profunctor
 , servant
@@ -67,7 +66,6 @@ mkDerivation {
     lens
     metrics-wai
     mtl
-    polysemy
     QuickCheck
     schema-profunctor
     servant

diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs
@@ -390,6 +390,7 @@ data ConversationUpdateResponse
   | ConversationUpdateResponseUpdate ConversationUpdate
   | ConversationUpdateResponseNoChanges
   | ConversationUpdateResponseNonFederatingBackends NonFederatingBackends
+  | ConversationUpdateResponseUnreachableBackends UnreachableBackends
   deriving stock (Eq, Show, Generic)
   deriving
     (ToJSON, FromJSON)

diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs
@@ -44,7 +44,6 @@ import Data.ByteString.Builder
 import Data.ByteString.Conversion (toByteString')
 import Data.ByteString.Lazy qualified as LBS
 import Data.Domain
-import Data.List.NonEmpty (NonEmpty)
 import Data.Sequence qualified as Seq
 import Data.Set qualified as Set
 import Data.Text.Encoding qualified as Text
@@ -226,13 +225,13 @@ withHTTP2StreamingRequest successfulStatus req handleResponse = do
         FederatorClientError
           ( mkFailureResponse
               (responseStatusCode resp)
-              [ceTargetDomain env]
+              (ceTargetDomain env)
               (toLazyByteString (requestPath req))
               (toLazyByteString bdy)
           )
 
-mkFailureResponse :: HTTP.Status -> NonEmpty Domain -> LByteString -> LByteString -> Wai.Error
-mkFailureResponse status domains path body
+mkFailureResponse :: HTTP.Status -> Domain -> LByteString -> LByteString -> Wai.Error
+mkFailureResponse status domain path body
   -- If the outward federator fails with 403, that means that there was an
   -- error at the level of the local federator (most likely due to a bug somewhere
   -- in wire-server). It does not make sense to return this error directly to the
@@ -252,7 +251,7 @@ mkFailureResponse status domains path body
         { Wai.errorData =
             Just
               Wai.FederationErrorData
-                { Wai.federrDomains = domains,
+                { Wai.federrDomain = domain,
                   Wai.federrPath =
                     "/federation"
                       <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path)

diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs
@@ -66,42 +66,34 @@
 -- error response from services during a federated call should be considered a bug
 -- in the implementation of the federation API, and is therefore wrapped in a 533.
 module Wire.API.Federation.Error
-  ( FederatorClientHTTP2Error (..),
+  ( -- * Federation errors
+    FederatorClientHTTP2Error (..),
     FederatorClientError (..),
     FederationError (..),
     VersionNegotiationError (..),
-    UnreachableBackendsError (..),
     federationErrorToWai,
     federationRemoteHTTP2Error,
     federationRemoteResponseError,
     federationNotImplemented,
     federationNotConfigured,
 
-    -- * utilities
-    throwUnreachableUsers,
-    throwUnreachableDomains,
+    -- * Error status codes
+    unexpectedFederationResponseStatus,
+    federatorConnectionRefusedStatus,
   )
 where
 
-import Data.Domain
-import Data.List.NonEmpty qualified as NE
-import Data.Qualified
-import Data.Set qualified as Set
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
 import Data.Text.Lazy qualified as LT
 import Imports
 import Network.HTTP.Types.Status
 import Network.HTTP.Types.Status qualified as HTTP
 import Network.HTTP2.Client qualified as HTTP2
-import Network.Wai.Utilities.Error
 import Network.Wai.Utilities.Error qualified as Wai
 import OpenSSL.Session (SomeSSLException)
-import Polysemy
-import Polysemy.Error qualified as P
 import Servant.Client
 import Wire.API.Error
-import Wire.API.Unreachable
 
 -- | Transport-layer errors in federator client.
 data FederatorClientHTTP2Error
@@ -167,11 +159,6 @@ data FederationError
     -- like "can't delete remote domains from config file", which is only
     -- needed until we start disregarding the config file.
     FederationUnexpectedError Text
-  | -- | One or more remote backends is unreachable
-    --
-    -- FUTUREWORK: Remove this data constructor and rely on the
-    -- 'UnreachableBackendsError' error type instead.
-    FederationUnreachableDomainsOld (Set Domain)
   deriving (Show, Typeable)
 
 data VersionNegotiationError
@@ -180,12 +167,6 @@ data VersionNegotiationError
   | RemoteTooNew
   deriving (Show, Typeable)
 
--- | A new error type in federation that describes a collection of unreachable
--- backends by providing their domains.
-newtype UnreachableBackendsError = UnreachableBackendsError
-  { unUnreachableBackendsError :: Set Domain
-  }
-
 versionNegotiationErrorMessage :: VersionNegotiationError -> LText
 versionNegotiationErrorMessage InvalidVersionInfo =
   "Remote federator returned invalid version information"
@@ -205,7 +186,6 @@ federationErrorToWai FederationNotConfigured = federationNotConfigured
 federationErrorToWai (FederationCallFailure err) = federationClientErrorToWai err
 federationErrorToWai (FederationUnexpectedBody s) = federationUnexpectedBody s
 federationErrorToWai (FederationUnexpectedError t) = federationUnexpectedError t
-federationErrorToWai (FederationUnreachableDomainsOld ds) = federationUnreachableError ds
 
 federationClientErrorToWai :: FederatorClientError -> Wai.Error
 federationClientErrorToWai (FederatorClientHTTP2Error e) =
@@ -332,17 +312,6 @@ federationUnexpectedError msg =
     "federation-unexpected-wai-error"
     ("Could parse body, but got an unexpected error response: " <> LT.fromStrict msg)
 
-federationUnreachableError :: Set Domain -> Wai.Error
-federationUnreachableError (Set.toList -> ds) =
-  Wai.Error
-    status
-    "federation-unreachable-domains-error"
-    ("The following domains are unreachable: " <> (LT.pack . show . map domainText) ds)
-    (flip FederationErrorData T.empty <$> NE.nonEmpty ds)
-  where
-    status :: Status
-    status = HTTP.Status 503 "Unreachable federated domains"
-
 federationNotConfigured :: Wai.Error
 federationNotConfigured =
   Wai.mkError
@@ -363,17 +332,3 @@ federationUnknownError =
     unexpectedFederationResponseStatus
     "unknown-federation-error"
     "Unknown federation error"
-
---------------------------------------------------------------------------------
--- Utilities
-
-throwUnreachableUsers :: Member (P.Error FederationError) r => UnreachableUsers -> Sem r a
-throwUnreachableUsers =
-  throwUnreachableDomains
-    . Set.fromList
-    . NE.toList
-    . fmap qDomain
-    . unreachableUsers
-
-throwUnreachableDomains :: Member (P.Error FederationError) r => Set Domain -> Sem r a
-throwUnreachableDomains = P.throw . FederationUnreachableDomainsOld
diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal
@@ -97,7 +97,6 @@ library
     , lens
     , metrics-wai
     , mtl
-    , polysemy
     , QuickCheck             >=2.13
     , schema-profunctor
     , servant                >=0.16

diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs
@@ -35,7 +35,6 @@ module Wire.API.Conversation
     cnvReceiptMode,
     cnvAccessRoles,
     CreateGroupConversation (..),
-    CreateConversationUnreachableBackends (..),
     ConversationCoverView (..),
     ConversationList (..),
     ListConversations (..),
@@ -314,22 +313,6 @@ instance ToSchema CreateGroupConversation where
       fromFlatList :: Ord a => [Qualified a] -> Map Domain (Set a)
       fromFlatList = fmap Set.fromList . indexQualified
 
-newtype CreateConversationUnreachableBackends = CreateConversationUnreachableBackends
-  { createConvUnreachableBackends :: Set Domain
-  }
-  deriving stock (Eq, Show, Generic)
-  deriving (Arbitrary) via (GenericUniform CreateConversationUnreachableBackends)
-  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CreateConversationUnreachableBackends
-
-instance ToSchema CreateConversationUnreachableBackends where
-  schema =
-    objectWithDocModifier
-      "CreateConversationUnreachableBackends"
-      (description ?~ "A federated conversation cannot be created because there are unreachable backends")
-      $ CreateConversationUnreachableBackends
-        <$> (Set.toList . createConvUnreachableBackends)
-          .= field "unreachable_backends" (Set.fromList <$> array schema)
-
 -- | Limited view of a 'Conversation'. Is used to inform users with an invite
 -- link about the conversation.
 data ConversationCoverView = ConversationCoverView
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1 @@
		Conversation creation endpoints can now return `unreachable_backends` error responses with status code 503 if any of the involved backends are unreachable. The conversation is not created in that case.