[FS-1148] Backport general changes from mls to develop (#3322)

* Backport changes from e90ea40 (PR #3304)

Author: mdimjasevic

changelog.d/1-api-changes/add-remotes-to-mls-conversation

@@ -0,0 +1 @@
+Throw when remote users to be added to an MLS conversation are unreachable

libs/wire-api-federation/default.nix

@@ -26,6 +26,7 @@
 , lib
 , metrics-wai
 , mtl
+, polysemy
 , QuickCheck
 , schema-profunctor
 , servant
@@ -66,6 +67,7 @@ mkDerivation {
     lens
     metrics-wai
     mtl
+    polysemy
     QuickCheck
     schema-profunctor
     servant

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

@@ -18,6 +18,7 @@
 module Wire.API.Federation.API.Galley where
 
 import Data.Aeson (FromJSON, ToJSON)
+import Data.Domain
 import Data.Id
 import Data.Json.Util
 import Data.Misc (Milliseconds)
@@ -423,7 +424,12 @@ data MLSMessageResponse
   = MLSMessageResponseError GalleyError
   | MLSMessageResponseProtocolError Text
   | MLSMessageResponseProposalFailure Wai.Error
-  | MLSMessageResponseUpdates [ConversationUpdate] (Maybe UnreachableUsers)
+  | -- | The conversation-owning backend could not reach some of the backends that
+    -- have users in the conversation when processing a commit.
+    MLSMessageResponseUnreachableBackends (Set Domain)
+  | -- | If the list of unreachable users is non-empty, it corresponds to users
+    -- that an application message could not be sent to.
+    MLSMessageResponseUpdates [ConversationUpdate] (Maybe UnreachableUsers)
   deriving stock (Eq, Show, Generic)
   deriving (ToJSON, FromJSON) via (CustomEncoded MLSMessageResponse)
 

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

@@ -75,9 +75,17 @@ module Wire.API.Federation.Error
     federationRemoteResponseError,
     federationNotImplemented,
     federationNotConfigured,
+
+    -- * utilities
+    throwUnreachableUsers,
+    throwUnreachableDomains,
   )
 where
 
+import Data.Domain
+import qualified Data.List.NonEmpty as NE
+import Data.Qualified
+import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Data.Text.Lazy as LT
@@ -87,8 +95,11 @@ import qualified Network.HTTP.Types.Status as HTTP
 import qualified Network.HTTP2.Client as HTTP2
 import qualified Network.Wai.Utilities.Error as Wai
 import OpenSSL.Session (SomeSSLException)
+import Polysemy
+import qualified Polysemy.Error as P
 import Servant.Client
 import Wire.API.Error
+import Wire.API.Unreachable
 
 -- | Transport-layer errors in federator client.
 data FederatorClientHTTP2Error
@@ -151,6 +162,8 @@ data FederationError
     FederationUnexpectedBody Text
   | -- | Federator client got an unexpected error response from remote backend
     FederationUnexpectedError Text
+  | -- | One or more remote backends is unreachable
+    FederationUnreachableDomains (Set Domain)
   deriving (Show, Typeable)
 
 data VersionNegotiationError
@@ -178,6 +191,7 @@ federationErrorToWai FederationNotConfigured = federationNotConfigured
 federationErrorToWai (FederationCallFailure err) = federationClientErrorToWai err
 federationErrorToWai (FederationUnexpectedBody s) = federationUnexpectedBody s
 federationErrorToWai (FederationUnexpectedError t) = federationUnexpectedError t
+federationErrorToWai (FederationUnreachableDomains ds) = federationUnreachableError ds
 
 federationClientErrorToWai :: FederatorClientError -> Wai.Error
 federationClientErrorToWai (FederatorClientHTTP2Error e) =
@@ -304,6 +318,16 @@ 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.map domainText -> ds) =
+  Wai.mkError
+    status
+    "federation-unreachable-domains-error"
+    ("The following domains are unreachable: " <> (LT.pack . show . Set.toList) ds)
+  where
+    status :: Status
+    status = HTTP.Status 503 "Unreachable federated domains"
+
 federationNotConfigured :: Wai.Error
 federationNotConfigured =
   Wai.mkError
@@ -324,3 +348,17 @@ 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 . FederationUnreachableDomains

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

@@ -42,10 +42,7 @@ spec =
     testObjects
       [ (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus1, "testObject_MLSMessageSendingStatus1.json"),
         (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus2, "testObject_MLSMessageSendingStatus2.json"),
-        (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus3, "testObject_MLSMessageSendingStatus3.json"),
-        (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus4, "testObject_MLSMessageSendingStatus4.json"),
-        (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus5, "testObject_MLSMessageSendingStatus5.json"),
-        (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus6, "testObject_MLSMessageSendingStatus6.json")
+        (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus3, "testObject_MLSMessageSendingStatus3.json")
       ]
     testObjects [(LeaveConversationRequest.testObject_LeaveConversationRequest1, "testObject_LeaveConversationRequest1.json")]
     testObjects

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

@@ -31,47 +31,23 @@ testObject_MLSMessageSendingStatus1 =
   MLSMessageSendingStatus
     { mmssEvents = [],
       mmssTime = toUTCTimeMillis (read "1864-04-12 12:22:43.673 UTC"),
-      mmssUnreachableUsers = mempty
+      mmssFailedToSendTo = mempty
     }
 
 testObject_MLSMessageSendingStatus2 :: MLSMessageSendingStatus
 testObject_MLSMessageSendingStatus2 =
   MLSMessageSendingStatus
     { mmssEvents = [],
       mmssTime = toUTCTimeMillis (read "2001-04-12 12:22:43.673 UTC"),
-      mmssUnreachableUsers = unreachableFromList failed1
+      mmssFailedToSendTo = unreachableFromList failed1
     }
 
 testObject_MLSMessageSendingStatus3 :: MLSMessageSendingStatus
 testObject_MLSMessageSendingStatus3 =
   MLSMessageSendingStatus
     { mmssEvents = [],
       mmssTime = toUTCTimeMillis (read "1999-04-12 12:22:43.673 UTC"),
-      mmssUnreachableUsers = unreachableFromList failed2
-    }
-
-testObject_MLSMessageSendingStatus4 :: MLSMessageSendingStatus
-testObject_MLSMessageSendingStatus4 =
-  MLSMessageSendingStatus
-    { mmssEvents = [],
-      mmssTime = toUTCTimeMillis (read "2023-04-12 12:22:43.673 UTC"),
-      mmssUnreachableUsers = unreachableFromList failed1
-    }
-
-testObject_MLSMessageSendingStatus5 :: MLSMessageSendingStatus
-testObject_MLSMessageSendingStatus5 =
-  MLSMessageSendingStatus
-    { mmssEvents = [],
-      mmssTime = toUTCTimeMillis (read "1901-04-12 12:22:43.673 UTC"),
-      mmssUnreachableUsers = unreachableFromList failed2
-    }
-
-testObject_MLSMessageSendingStatus6 :: MLSMessageSendingStatus
-testObject_MLSMessageSendingStatus6 =
-  MLSMessageSendingStatus
-    { mmssEvents = [],
-      mmssTime = toUTCTimeMillis (read "1905-04-12 12:22:43.673 UTC"),
-      mmssUnreachableUsers = unreachableFromList failed1 <> unreachableFromList failed2
+      mmssFailedToSendTo = unreachableFromList failed2
     }
 
 failed1 :: [Qualified UserId]

libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json

@@ -97,6 +97,7 @@ library
     , lens
     , metrics-wai
     , mtl
+    , polysemy
     , QuickCheck             >=2.13
     , schema-profunctor
     , servant                >=0.16