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

* Backport changes from e90ea40 (PR #3304)
wireapp · Jun 2, 2023 · 2ff7378 · 2ff7378
1 parent 59e5b33
commit 2ff7378
Show file tree

Hide file tree

Showing 16 changed files with 95 additions and 107 deletions.
diff --git a/changelog.d/1-api-changes/add-remotes-to-mls-conversation b/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
diff --git a/libs/wire-api-federation/default.nix b/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

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
@@ -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)
 

diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/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
diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs b/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

diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs b/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]

diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json
diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json
diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json
diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal
@@ -97,6 +97,7 @@ library
     , lens
     , metrics-wai
     , mtl
+    , polysemy
     , QuickCheck             >=2.13
     , schema-profunctor
     , servant                >=0.16

diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs
@@ -319,7 +319,10 @@ instance SerialiseMLS (MessagePayload 'MLSPlainText) where
 data MLSMessageSendingStatus = MLSMessageSendingStatus
   { mmssEvents :: [Event],
     mmssTime :: UTCTimeMillis,
-    mmssUnreachableUsers :: Maybe UnreachableUsers
+    -- | An optional list of unreachable users an application message could not
+    -- be sent to. In case of commits and unreachable users use the
+    -- MLSMessageResponseUnreachableBackends data constructor.
+    mmssFailedToSendTo :: Maybe UnreachableUsers
   }
   deriving (Eq, Show)
   deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema MLSMessageSendingStatus
@@ -338,7 +341,7 @@ instance ToSchema MLSMessageSendingStatus where
             "time"
             (description ?~ "The time of sending the message.")
             schema
-        <*> mmssUnreachableUsers
+        <*> mmssFailedToSendTo
           .= maybe_
             ( optFieldWithDocModifier
                 "failed_to_send"

diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs
@@ -745,15 +745,15 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do
     -- For now these users will not be able to join the conversation until
     -- queueing and retrying is implemented.
     let failedNotifies = lefts notifyEithers
+    for_ failedNotifies $
+      logError
+        "on-new-remote-conversation"
+        "An error occurred while communicating with federated server: "
     for_ failedNotifies $ \case
       -- rethrow invalid-domain errors and mis-configured federation errors
       (_, ex@(FederationCallFailure (FederatorClientError (Wai.Error (Wai.Status 422 _) _ _ _)))) -> throw ex
       (_, ex@(FederationCallFailure (FederatorClientHTTP2Error (FederatorClientConnectionError _)))) -> throw ex
       _ -> pure ()
-    for_ failedNotifies $
-      logError
-        "on-new-remote-conversation"
-        "An error occurred while communicating with federated server: "
     updates <-
       E.runFederatedConcurrentlyEither (toList (bmRemotes targets)) $
         \ruids -> do

diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs
@@ -548,8 +548,7 @@ sendMLSCommitBundle remoteDomain msr =
       let msg = rmValue (cbCommitMsg bundle)
       qcnv <- E.getConversationIdByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound
       when (Conv (qUnqualified qcnv) /= F.mmsrConvOrSubId msr) $ throwS @'MLSGroupConversationMismatch
-      uncurry F.MLSMessageResponseUpdates
-        . first (map lcuUpdate)
+      uncurry F.MLSMessageResponseUpdates . (,mempty) . map lcuUpdate
         <$> postMLSCommitBundle loc (tUntagged sender) Nothing qcnv Nothing bundle
 
 sendMLSMessage ::