From 352f01c0a293fdf09dca12a635c06ea8e74320be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 9 May 2023 10:06:38 +0200 Subject: [PATCH] Revert "[FS-1148] Resilient member adding in presence of unreachable backends (1/2) (#3248)" This reverts commit 4a4ba8dd54586e1d85fe4af609990d79ae3d8cc2. --- .../mls-conv-add-across-federation | 1 - changelog.d/6-federation/failed-to-process | 1 - .../src/Wire/API/Federation/API/Galley.hs | 10 +- .../Wire/API/Federation/Golden/GoldenSpec.hs | 5 +- .../Golden/LeaveConversationResponse.hs | 2 +- .../Golden/MLSMessageSendingStatus.hs | 45 ++--- ...testObject_LeaveConversationResponse1.json | 2 +- .../testObject_MLSMessageSendingStatus1.json | 7 +- .../testObject_MLSMessageSendingStatus4.json | 10 -- .../testObject_MLSMessageSendingStatus5.json | 14 -- .../testObject_MLSMessageSendingStatus6.json | 20 --- libs/wire-api/src/Wire/API/MLS/Message.hs | 24 ++- libs/wire-api/src/Wire/API/Unreachable.hs | 127 -------------- libs/wire-api/wire-api.cabal | 1 - .../federator/src/Federator/MockServer.hs | 12 -- services/galley/src/Galley/API/Action.hs | 125 ++++++-------- services/galley/src/Galley/API/Federation.hs | 125 +++++--------- services/galley/src/Galley/API/LegalHold.hs | 10 -- services/galley/src/Galley/API/MLS/Message.hs | 163 +++++++----------- .../galley/src/Galley/API/MLS/Propagate.hs | 6 +- .../galley/src/Galley/API/Teams/Features.hs | 2 - services/galley/src/Galley/API/Update.hs | 39 ++--- services/galley/src/Galley/Types/UserList.hs | 8 - services/galley/test/integration/API.hs | 31 ++-- .../galley/test/integration/API/Federation.hs | 4 +- services/galley/test/integration/API/MLS.hs | 102 +++-------- .../galley/test/integration/API/MLS/Mocks.hs | 36 ++-- .../galley/test/integration/API/MLS/Util.hs | 20 +-- .../test/integration/API/Teams/LegalHold.hs | 2 +- services/galley/test/integration/API/Util.hs | 17 +- 30 files changed, 294 insertions(+), 677 deletions(-) delete mode 100644 changelog.d/1-api-changes/mls-conv-add-across-federation delete mode 100644 changelog.d/6-federation/failed-to-process delete mode 100644 libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json delete mode 100644 libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json delete mode 100644 libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json delete mode 100644 libs/wire-api/src/Wire/API/Unreachable.hs diff --git a/changelog.d/1-api-changes/mls-conv-add-across-federation b/changelog.d/1-api-changes/mls-conv-add-across-federation deleted file mode 100644 index 6c86f1106bf..00000000000 --- a/changelog.d/1-api-changes/mls-conv-add-across-federation +++ /dev/null @@ -1 +0,0 @@ -Report a failure to add remote users to an MLS conversation diff --git a/changelog.d/6-federation/failed-to-process b/changelog.d/6-federation/failed-to-process deleted file mode 100644 index 22edab941ae..00000000000 --- a/changelog.d/6-federation/failed-to-process +++ /dev/null @@ -1 +0,0 @@ -Several federation Galley endpoints have a breaking change in their response types: "leave-conversation", "update-conversation", "send-mls-message" and "send-mls-commit-bundle". 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 index b282a387ddb..8a0422c5f2e 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -35,11 +35,11 @@ import Wire.API.Conversation.Typing import Wire.API.Error.Galley import Wire.API.Federation.API.Common import Wire.API.Federation.Endpoint +import Wire.API.MLS.Message import Wire.API.MLS.SubConversation import Wire.API.MakesFederatedCall import Wire.API.Message import Wire.API.Routes.Public.Galley.Messaging -import Wire.API.Unreachable import Wire.API.Util.Aeson (CustomEncoded (..)) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) @@ -365,11 +365,11 @@ newtype MessageSendResponse = MessageSendResponse ) newtype LeaveConversationResponse = LeaveConversationResponse - {leaveResponse :: Either RemoveFromConversationError FailedToProcess} + {leaveResponse :: Either RemoveFromConversationError ()} deriving stock (Eq, Show) deriving (ToJSON, FromJSON) - via (Either (CustomEncoded RemoveFromConversationError) FailedToProcess) + via (Either (CustomEncoded RemoveFromConversationError) ()) type UserDeletedNotificationMaxConvs = 1000 @@ -398,7 +398,7 @@ data ConversationUpdateRequest = ConversationUpdateRequest data ConversationUpdateResponse = ConversationUpdateResponseError GalleyError - | ConversationUpdateResponseUpdate (ConversationUpdate, FailedToProcess) + | ConversationUpdateResponseUpdate ConversationUpdate | ConversationUpdateResponseNoChanges deriving stock (Eq, Show, Generic) deriving @@ -423,7 +423,7 @@ data MLSMessageResponse = MLSMessageResponseError GalleyError | MLSMessageResponseProtocolError Text | MLSMessageResponseProposalFailure Wai.Error - | MLSMessageResponseUpdates [ConversationUpdate] FailedToProcess + | MLSMessageResponseUpdates [ConversationUpdate] UnreachableUsers deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON) via (CustomEncoded MLSMessageResponse) 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 index 0acf15af8bf..5bc03b0398b 100644 --- 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/LeaveConversationResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs index 0620028b18e..05137a27136 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs @@ -21,7 +21,7 @@ import Imports import Wire.API.Federation.API.Galley testObject_LeaveConversationResponse1 :: LeaveConversationResponse -testObject_LeaveConversationResponse1 = LeaveConversationResponse $ Right mempty +testObject_LeaveConversationResponse1 = LeaveConversationResponse $ Right () testObject_LeaveConversationResponse2 :: LeaveConversationResponse testObject_LeaveConversationResponse2 = LeaveConversationResponse $ Left RemoveFromConversationErrorRemovalNotAllowed 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 index 32a420f419d..0e228bec42d 100644 --- 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 @@ -24,14 +24,13 @@ import Data.Qualified import qualified Data.UUID as UUID import Imports import Wire.API.MLS.Message -import Wire.API.Unreachable testObject_MLSMessageSendingStatus1 :: MLSMessageSendingStatus testObject_MLSMessageSendingStatus1 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "1864-04-12 12:22:43.673 UTC"), - mmssFailedToProcess = mempty + mmssUnreachableUsers = UnreachableUsers [] } testObject_MLSMessageSendingStatus2 :: MLSMessageSendingStatus @@ -39,7 +38,7 @@ testObject_MLSMessageSendingStatus2 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "2001-04-12 12:22:43.673 UTC"), - mmssFailedToProcess = failedToSend failed1 + mmssUnreachableUsers = failed1 } testObject_MLSMessageSendingStatus3 :: MLSMessageSendingStatus @@ -47,42 +46,18 @@ testObject_MLSMessageSendingStatus3 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "1999-04-12 12:22:43.673 UTC"), - mmssFailedToProcess = failedToSend failed2 + mmssUnreachableUsers = failed2 } -testObject_MLSMessageSendingStatus4 :: MLSMessageSendingStatus -testObject_MLSMessageSendingStatus4 = - MLSMessageSendingStatus - { mmssEvents = [], - mmssTime = toUTCTimeMillis (read "2023-04-12 12:22:43.673 UTC"), - mmssFailedToProcess = failedToAdd failed1 - } - -testObject_MLSMessageSendingStatus5 :: MLSMessageSendingStatus -testObject_MLSMessageSendingStatus5 = - MLSMessageSendingStatus - { mmssEvents = [], - mmssTime = toUTCTimeMillis (read "1901-04-12 12:22:43.673 UTC"), - mmssFailedToProcess = failedToRemove failed2 - } - -testObject_MLSMessageSendingStatus6 :: MLSMessageSendingStatus -testObject_MLSMessageSendingStatus6 = - MLSMessageSendingStatus - { mmssEvents = [], - mmssTime = toUTCTimeMillis (read "1905-04-12 12:22:43.673 UTC"), - mmssFailedToProcess = failedToAdd failed1 <> failedToRemove failed2 - } - -failed1 :: [Qualified UserId] +failed1 :: UnreachableUsers failed1 = let domain = Domain "offline.example.com" - in [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] + in UnreachableUsers [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] -failed2 :: [Qualified UserId] +failed2 :: UnreachableUsers failed2 = let domain = Domain "golden.example.com" - in flip Qualified domain . Id . fromJust . UUID.fromString - <$> [ "00000000-0000-0000-0000-000200000008", - "00000000-0000-0000-0000-000100000007" - ] + in UnreachableUsers + [ Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain, + Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000100000007") domain + ] diff --git a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json index 31e2f71f181..5ce20f1d241 100644 --- a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json +++ b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json @@ -1,3 +1,3 @@ { - "Right": {} + "Right": [] } \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json index dcd87fe9466..9323f7742ed 100644 --- a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json @@ -1,4 +1,5 @@ { - "events": [], - "time": "1864-04-12T12:22:43.673Z" -} \ No newline at end of file + "events": [], + "time": "1864-04-12T12:22:43.673Z", + "failed_to_send": [] +} diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json deleted file mode 100644 index 50831a654f2..00000000000 --- a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json +++ /dev/null @@ -1,10 +0,0 @@ -{ - "events": [], - "failed_to_add": [ - { - "domain": "offline.example.com", - "id": "00000000-0000-0000-0000-000200000008" - } - ], - "time": "2023-04-12T12:22:43.673Z" -} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json deleted file mode 100644 index a3a97ffbecb..00000000000 --- a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json +++ /dev/null @@ -1,14 +0,0 @@ -{ - "events": [], - "failed_to_remove": [ - { - "domain": "golden.example.com", - "id": "00000000-0000-0000-0000-000200000008" - }, - { - "domain": "golden.example.com", - "id": "00000000-0000-0000-0000-000100000007" - } - ], - "time": "1901-04-12T12:22:43.673Z" -} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json deleted file mode 100644 index 53ebbd357bb..00000000000 --- a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json +++ /dev/null @@ -1,20 +0,0 @@ -{ - "events": [], - "failed_to_add": [ - { - "domain": "offline.example.com", - "id": "00000000-0000-0000-0000-000200000008" - } - ], - "failed_to_remove": [ - { - "domain": "golden.example.com", - "id": "00000000-0000-0000-0000-000200000008" - }, - { - "domain": "golden.example.com", - "id": "00000000-0000-0000-0000-000100000007" - } - ], - "time": "1905-04-12T12:22:43.673Z" -} \ No newline at end of file diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 89bda69ab4e..1787ceab4bf 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -37,6 +37,7 @@ module Wire.API.MLS.Message MLSCipherTextSym0, MLSMessageSendingStatus (..), KnownFormatTag (..), + UnreachableUsers (..), verifyMessageSignature, mkSignedMessage, ) @@ -49,8 +50,10 @@ import Data.Binary import Data.Binary.Get import Data.Binary.Put import qualified Data.ByteArray as BA +import Data.Id import Data.Json.Util import Data.Kind +import Data.Qualified import Data.Schema import Data.Singletons.TH import qualified Data.Swagger as S @@ -64,7 +67,6 @@ import Wire.API.MLS.Group import Wire.API.MLS.KeyPackage import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation -import Wire.API.Unreachable import Wire.Arbitrary (GenericUniform (..)) data WireFormatTag = MLSPlainText | MLSCipherText @@ -316,10 +318,22 @@ instance SerialiseMLS (MessagePayload 'MLSPlainText) where -- so the next case is left as a stub serialiseMLS _ = pure () +newtype UnreachableUsers = UnreachableUsers {unreachableUsers :: [Qualified UserId]} + deriving stock (Eq, Show) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUsers + deriving newtype (Semigroup, Monoid) + +instance ToSchema UnreachableUsers where + schema = + named "UnreachableUsers" $ + UnreachableUsers + <$> unreachableUsers + .= array schema + data MLSMessageSendingStatus = MLSMessageSendingStatus { mmssEvents :: [Event], mmssTime :: UTCTimeMillis, - mmssFailedToProcess :: FailedToProcess + mmssUnreachableUsers :: UnreachableUsers } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema MLSMessageSendingStatus @@ -338,7 +352,11 @@ instance ToSchema MLSMessageSendingStatus where "time" (description ?~ "The time of sending the message.") schema - <*> mmssFailedToProcess .= failedToProcessObjectSchema + <*> mmssUnreachableUsers + .= fieldWithDocModifier + "failed_to_send" + (description ?~ "List of federated users who could not be reached and did not receive the message") + schema verifyMessageSignature :: CipherSuiteTag -> Message 'MLSPlainText -> ByteString -> Bool verifyMessageSignature cs msg pubkey = diff --git a/libs/wire-api/src/Wire/API/Unreachable.hs b/libs/wire-api/src/Wire/API/Unreachable.hs deleted file mode 100644 index 69725e53d04..00000000000 --- a/libs/wire-api/src/Wire/API/Unreachable.hs +++ /dev/null @@ -1,127 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - --- | Types and utilies around unreachable backends and failing to process --- various kinds of messages. -module Wire.API.Unreachable - ( -- * Failed to process - UnreachableUsers (unreachableUsers), - unreachableFromList, - FailedToProcess (..), - failedToProcessObjectSchema, - failedToSend, - failedToSendMaybe, - failedToAdd, - failedToAddMaybe, - failedToRemove, - failedToRemoveMaybe, - ) -where - -import Control.Lens ((?~)) -import qualified Data.Aeson as A -import Data.Id -import Data.List.NonEmpty -import qualified Data.List.NonEmpty as NE -import Data.Qualified -import Data.Schema -import qualified Data.Swagger as S -import Imports - -newtype UnreachableUsers = UnreachableUsers {unreachableUsers :: NonEmpty (Qualified UserId)} - deriving stock (Eq, Show) - deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUsers - -instance Semigroup UnreachableUsers where - (UnreachableUsers m) <> (UnreachableUsers n) = UnreachableUsers . NE.nub $ m <> n - -instance ToSchema UnreachableUsers where - schema = - named "UnreachableUsers" $ - UnreachableUsers - <$> unreachableUsers - .= nonEmptyArray schema - -unreachableFromList :: [Qualified UserId] -> Maybe UnreachableUsers -unreachableFromList = fmap (UnreachableUsers . NE.nub) . nonEmpty - --- | Lists of remote users that could not be processed in a federated action, --- e.g., a message could not be sent to these remote users. -data FailedToProcess = FailedToProcess - { send :: Maybe UnreachableUsers, - add :: Maybe UnreachableUsers, - remove :: Maybe UnreachableUsers - } - deriving (Eq, Show) - deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema FailedToProcess - -instance Semigroup FailedToProcess where - ftp1 <> ftp2 = - FailedToProcess - { send = send ftp1 <> send ftp2, - add = add ftp1 <> add ftp2, - remove = remove ftp1 <> remove ftp2 - } - -instance Monoid FailedToProcess where - mempty = FailedToProcess mempty mempty mempty - -failedToProcessObjectSchema :: ObjectSchema SwaggerDoc FailedToProcess -failedToProcessObjectSchema = - FailedToProcess - <$> send - .= maybe_ - ( optFieldWithDocModifier - "failed_to_send" - (description ?~ "List of federated users who could not be reached and did not receive the message") - (unnamed schema) - ) - <*> add - .= maybe_ - ( optFieldWithDocModifier - "failed_to_add" - (description ?~ "List of federated users who could not be reached and be added to a conversation") - (unnamed schema) - ) - <*> remove - .= maybe_ - ( optFieldWithDocModifier - "failed_to_remove" - (description ?~ "List of federated users who could not be reached and be removed from a conversation") - (unnamed schema) - ) - -instance ToSchema FailedToProcess where - schema = object "FailedToProcess" failedToProcessObjectSchema - -failedToSend :: [Qualified UserId] -> FailedToProcess -failedToSend = failedToSendMaybe . unreachableFromList - -failedToSendMaybe :: Maybe UnreachableUsers -> FailedToProcess -failedToSendMaybe us = mempty {send = us} - -failedToAdd :: [Qualified UserId] -> FailedToProcess -failedToAdd = failedToAddMaybe . unreachableFromList - -failedToAddMaybe :: Maybe UnreachableUsers -> FailedToProcess -failedToAddMaybe us = mempty {add = us} - -failedToRemove :: [Qualified UserId] -> FailedToProcess -failedToRemove = failedToRemoveMaybe . unreachableFromList - -failedToRemoveMaybe :: Maybe UnreachableUsers -> FailedToProcess -failedToRemoveMaybe us = mempty {remove = us} diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 099ac029fa7..4e8d1054562 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -138,7 +138,6 @@ library Wire.API.Team.Role Wire.API.Team.SearchVisibility Wire.API.Team.Size - Wire.API.Unreachable Wire.API.User Wire.API.User.Activation Wire.API.User.Auth diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index ed40cc9d954..f8f88e53108 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -28,7 +28,6 @@ module Federator.MockServer Mock, runMock, mockReply, - mockUnreachableFor, mockFail, guardRPC, guardComponent, @@ -46,7 +45,6 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import qualified Data.Aeson as Aeson import Data.Domain (Domain) -import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Lazy as LText import Federator.Error @@ -205,16 +203,6 @@ guardComponent c = do mockReply :: Aeson.ToJSON a => a -> Mock LByteString mockReply = pure . Aeson.encode --- | Provide a mock reply simulating unreachable backends given by their --- domains. -mockUnreachableFor :: String -> Set Domain -> Mock LByteString -mockUnreachableFor msg backends = do - target <- frTargetDomain <$> getRequest - guard (target `elem` backends) - if Set.member target backends - then throw (MockErrorResponse HTTP.status503 "Down for maintenance.") - else mockReply msg - -- | Abort the mock with an error. mockFail :: Text -> Mock a mockFail = Mock . lift . lift . throwE diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 4412315df3e..dfe49a05951 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -78,8 +78,6 @@ import Galley.Types.Conversations.Members import Galley.Types.UserList import Galley.Validation import Imports -import qualified Network.HTTP.Types.Status as Wai -import qualified Network.Wai.Utilities.Error as Wai import Polysemy import Polysemy.Error import Polysemy.Input @@ -99,7 +97,6 @@ import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.Team.LegalHold import Wire.API.Team.Member -import Wire.API.Unreachable import qualified Wire.API.User as User data NoChanges = NoChanges @@ -293,8 +290,7 @@ ensureAllowed tag loc action conv origUser = do -- and also returns the (possible modified) action that was performed performAction :: forall tag r. - ( HasConversationActionEffects tag r, - Member (Error FederationError) r + ( HasConversationActionEffects tag r ) => Sing tag -> Qualified UserId -> @@ -425,8 +421,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do ensureConnectedToRemotes lusr remotes checkLHPolicyConflictsLocal :: - ( Member (Error FederationError) r, - Member (Error InternalError) r, + ( Member (Error InternalError) r, Member (ErrorS 'MissingLegalholdConsent) r, Member ExternalAccess r, Member FederatorAccess r, @@ -481,8 +476,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do checkLHPolicyConflictsRemote _remotes = pure () performConversationAccessData :: - ( HasConversationActionEffects 'ConversationAccessDataTag r, - Member (Error FederationError) r + ( HasConversationActionEffects 'ConversationAccessDataTag r ) => Qualified UserId -> Local Conversation -> @@ -569,7 +563,6 @@ data LocalConversationUpdate = LocalConversationUpdate updateLocalConversation :: forall tag r. ( Member ConversationStore r, - Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, @@ -585,7 +578,7 @@ updateLocalConversation :: Qualified UserId -> Maybe ConnId -> ConversationAction tag -> - Sem r (LocalConversationUpdate, FailedToProcess) + Sem r LocalConversationUpdate updateLocalConversation lcnv qusr con action = do let tag = sing @tag @@ -609,7 +602,6 @@ updateLocalConversation lcnv qusr con action = do updateLocalConversationUnchecked :: forall tag r. ( SingI tag, - Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, @@ -624,7 +616,7 @@ updateLocalConversationUnchecked :: Qualified UserId -> Maybe ConnId -> ConversationAction tag -> - Sem r (LocalConversationUpdate, FailedToProcess) + Sem r LocalConversationUpdate updateLocalConversationUnchecked lconv qusr con action = do let tag = sing @tag lcnv = fmap convId lconv @@ -640,6 +632,11 @@ updateLocalConversationUnchecked lconv qusr con action = do (extraTargets, action') <- performAction tag qusr lconv action notifyConversationAction + -- Removing members should be fault tolerant. + ( case tag of + SConversationRemoveMembersTag -> False + _ -> True + ) (sing @tag) qusr False @@ -694,13 +691,13 @@ addMembersToLocalConversation lcnv users role = do notifyConversationAction :: forall tag r. - ( Member (Error FederationError) r, - Member FederatorAccess r, + ( Member FederatorAccess r, Member ExternalAccess r, Member GundeckAccess r, Member (Input UTCTime) r, Member (Logger (Log.Msg -> Log.Msg)) r ) => + Bool -> Sing tag -> Qualified UserId -> Bool -> @@ -708,8 +705,8 @@ notifyConversationAction :: Local Conversation -> BotsAndMembers -> ConversationAction (tag :: ConversationActionTag) -> - Sem r (LocalConversationUpdate, FailedToProcess) -notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do + Sem r LocalConversationUpdate +notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets action = do now <- input let lcnv = fmap convId lconv conv = tUnqualified lconv @@ -729,68 +726,58 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do Set.difference (Set.map void (bmRemotes targets)) (Set.fromList (map (void . rmId) (convRemoteMembers conv))) - newRemotes = - Set.filter (\r -> Set.member (void r) newDomains) - . bmRemotes - $ targets let nrc = NewRemoteConversation { nrcConvId = convId conv, nrcProtocol = convProtocol conv } - (update, failedToProcess) <- do - notifyEithers <- - E.runFederatedConcurrentlyEither (toList newRemotes) $ \_ -> do - void $ fedClient @'Galley @"on-new-remote-conversation" nrc - -- For now these users will not be able to join the conversation until - -- queueing and retrying is implemented. - let failedNotifies = lefts notifyEithers - 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 - let update = mkUpdate (tUnqualified ruids) - -- if notifyOrigDomain is false, filter out user from quid's domain, - -- because quid's backend will update local state and notify its users - -- itself using the ConversationUpdate returned by this function - if notifyOrigDomain || tDomain ruids /= qDomain quid - then fedClient @'Galley @"on-conversation-updated" update $> Nothing - else pure (Just update) - let f = fromMaybe (mkUpdate []) . asum . map tUnqualified . rights - update = f updates - failedUpdates = lefts updates - toFailedToProcess :: [Qualified UserId] -> FailedToProcess - toFailedToProcess us = case tag of - SConversationJoinTag -> failedToAdd us - SConversationLeaveTag -> failedToRemove us - SConversationRemoveMembersTag -> failedToRemove us - _ -> mempty - for_ failedUpdates $ - logError - "on-conversation-updated" - "An error occurred while communicating with federated server: " - let totalFailedToProcess = - failedToAdd (qualifiedFails failedNotifies) - <> toFailedToProcess (qualifiedFails failedUpdates) - pure (update, totalFailedToProcess) + let errorIntolerant = do + E.runFederatedConcurrently_ (toList newDomains) $ \_ -> do + void $ fedClient @'Galley @"on-new-remote-conversation" nrc + fmap (fromMaybe (mkUpdate []) . asum . map tUnqualified) + . E.runFederatedConcurrently (toList (bmRemotes targets)) + $ \ruids -> do + let update = mkUpdate (tUnqualified ruids) + -- if notifyOrigDomain is false, filter out user from quid's domain, + -- because quid's backend will update local state and notify its users + -- itself using the ConversationUpdate returned by this function + if notifyOrigDomain || tDomain ruids /= qDomain quid + then fedClient @'Galley @"on-conversation-updated" update $> Nothing + else pure (Just update) + errorTolerant = do + fedEithers <- E.runFederatedConcurrentlyEither (toList newDomains) $ \_ -> do + void $ fedClient @'Galley @"on-new-remote-conversation" nrc + for_ fedEithers $ + either + (logError "on-new-remote-conversation" "An error occurred while communicating with federated server: ") + (pure . tUnqualified) + updates <- + E.runFederatedConcurrentlyEither (toList (bmRemotes targets)) $ + \ruids -> do + let update = mkUpdate (tUnqualified ruids) + -- if notifyOrigDomain is false, filter out user from quid's domain, + -- because quid's backend will update local state and notify its users + -- itself using the ConversationUpdate returned by this function + if notifyOrigDomain || tDomain ruids /= qDomain quid + then fedClient @'Galley @"on-conversation-updated" update $> Nothing + else pure (Just update) + let f = fromMaybe (mkUpdate []) . asum . map tUnqualified . rights + update = f updates + for_ (lefts updates) $ + logError + "on-conversation-update" + "An error occurred while communicating with federated server: " + pure update + + update <- if failEarly then errorIntolerant else errorTolerant -- notify local participants and bots pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) -- return both the event and the 'ConversationUpdate' structure corresponding -- to the originating domain (if it is remote) - pure $ (LocalConversationUpdate e update, failedToProcess) + pure $ LocalConversationUpdate e update where - qualifiedFails :: [(QualifiedWithTag t [a], b)] -> [Qualified a] - qualifiedFails = foldMap (sequenceA . tUntagged . fst) logError :: Show a => String -> String -> (a, FederationError) -> Sem r () logError field msg e = P.warn $ @@ -846,8 +833,7 @@ notifyRemoteConversationAction loc rconvUpdate con = do -- leave, but then sends notifications as if the user was removed by someone -- else. kickMember :: - ( Member (Error FederationError) r, - Member (Error InternalError) r, + ( Member (Error InternalError) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, @@ -870,6 +856,7 @@ kickMember qusr lconv targets victim = void . runError @NoChanges $ do lconv () notifyConversationAction + False (sing @'ConversationRemoveMembersTag) qusr True diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 606206c674f..11f24556efd 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -25,7 +25,6 @@ import Data.Bifunctor import Data.ByteString.Conversion (toByteString') import Data.Containers.ListUtils (nubOrd) import Data.Domain (Domain) -import Data.Either.Combinators import Data.Id import Data.Json.Util import Data.List.NonEmpty (NonEmpty (..)) @@ -345,7 +344,7 @@ leaveConversation :: F.LeaveConversationRequest -> Sem r F.LeaveConversationResponse leaveConversation requestingDomain lc = do - let leaver = Qualified (F.lcLeaver lc) requestingDomain + let leaver :: Remote UserId = qTagUnsafe $ Qualified (F.lcLeaver lc) requestingDomain lcnv <- qualifyLocal (F.lcConvId lc) res <- @@ -355,48 +354,34 @@ leaveConversation requestingDomain lc = do . mapToRuntimeError @'InvalidOperation F.RemoveFromConversationErrorRemovalNotAllowed . mapError @NoChanges (const F.RemoveFromConversationErrorUnchanged) $ do - (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound leaver lcnv - outcome <- - runError @FederationError $ - first lcuUpdate - <$> updateLocalConversation - @'ConversationLeaveTag - lcnv - leaver - Nothing - () - case outcome of - Left e -> do - logFederationError lcnv e - throw . internalErr $ e - Right update -> pure (update, conv) + (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound (tUntagged leaver) lcnv + update <- + lcuUpdate + <$> updateLocalConversation + @'ConversationLeaveTag + lcnv + (tUntagged leaver) + Nothing + () + pure (update, conv) case res of Left e -> pure $ F.LeaveConversationResponse (Left e) - Right ((_update, updateFailedToProcess), conv) -> do - let remotes = filter ((== qDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) + Right (_update, conv) -> do + let remotes = filter ((== tDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) let botsAndMembers = BotsAndMembers mempty (Set.fromList remotes) mempty - (_, notifyFailedToProcess) <- do - outcome <- - runError @FederationError $ - notifyConversationAction - SConversationLeaveTag - leaver - False - Nothing - (qualifyAs lcnv conv) - botsAndMembers - () - case outcome of - Left e -> do - logFederationError lcnv e - throw . internalErr $ e - Right v -> pure v - - pure . F.LeaveConversationResponse . Right $ - updateFailedToProcess <> notifyFailedToProcess - where - internalErr = InternalErrorWithDescription . LT.pack . displayException + _ <- + notifyConversationAction + False + SConversationLeaveTag + (tUntagged leaver) + False + Nothing + (qualifyAs lcnv conv) + botsAndMembers + () + + pure $ F.LeaveConversationResponse (Right ()) -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients @@ -513,17 +498,16 @@ onUserDeleted origDomain udcn = do Public.RegularConv -> do let botsAndMembers = convBotsAndMembers conv removeUser (qualifyAs lc conv) (tUntagged deletedUser) - outcome <- - runError @FederationError $ - notifyConversationAction - (sing @'ConversationLeaveTag) - untaggedDeletedUser - False - Nothing - (qualifyAs lc conv) - botsAndMembers - () - whenLeft outcome . logFederationError $ lc + void $ + notifyConversationAction + False + (sing @'ConversationLeaveTag) + untaggedDeletedUser + False + Nothing + (qualifyAs lc conv) + botsAndMembers + () pure EmptyResponse updateConversation :: @@ -561,46 +545,46 @@ updateConversation origDomain updateRequest = do SomeConversationAction tag action -> case tag of SConversationJoinTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationJoinTag) - . fmap (first lcuUpdate) + . fmap lcuUpdate $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged rusr) Nothing action SConversationLeaveTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationLeaveTag) - . fmap (first lcuUpdate) + . fmap lcuUpdate $ updateLocalConversation @'ConversationLeaveTag lcnv (tUntagged rusr) Nothing action SConversationRemoveMembersTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationRemoveMembersTag) - . fmap (first lcuUpdate) + . fmap lcuUpdate $ updateLocalConversation @'ConversationRemoveMembersTag lcnv (tUntagged rusr) Nothing action SConversationMemberUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationMemberUpdateTag) - . fmap (first lcuUpdate) + . fmap lcuUpdate $ updateLocalConversation @'ConversationMemberUpdateTag lcnv (tUntagged rusr) Nothing action SConversationDeleteTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationDeleteTag) - . fmap (first lcuUpdate) + . fmap lcuUpdate $ updateLocalConversation @'ConversationDeleteTag lcnv (tUntagged rusr) Nothing action SConversationRenameTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationRenameTag) - . fmap (first lcuUpdate) + . fmap lcuUpdate $ updateLocalConversation @'ConversationRenameTag lcnv (tUntagged rusr) Nothing action SConversationMessageTimerUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationMessageTimerUpdateTag) - . fmap (first lcuUpdate) + . fmap lcuUpdate $ updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv (tUntagged rusr) Nothing action SConversationReceiptModeUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationReceiptModeUpdateTag) - . fmap (first lcuUpdate) + . fmap lcuUpdate $ updateLocalConversation @'ConversationReceiptModeUpdateTag lcnv (tUntagged rusr) Nothing action SConversationAccessDataTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationAccessDataTag) - . fmap (first lcuUpdate) + . fmap lcuUpdate $ updateLocalConversation @'ConversationAccessDataTag lcnv (tUntagged rusr) Nothing action where mkResponse = fmap toResponse . runError @GalleyError . runError @NoChanges @@ -846,24 +830,3 @@ onTypingIndicatorUpdated origDomain TypingDataUpdated {..} = do let qcnv = Qualified tudConvId origDomain pushTypingIndicatorEvents tudOrigUserId tudTime tudUsersInConv Nothing qcnv tudTypingStatus pure EmptyResponse - --------------------------------------------------------------------------------- --- Utilities --------------------------------------------------------------------------------- - --- | Log a federation error that is impossible in processing a remote request --- for a local conversation. -logFederationError :: - Member P.TinyLog r => - Local ConvId -> - FederationError -> - Sem r () -logFederationError lc e = - P.warn $ - Log.field "conversation" (toByteString' (tUnqualified lc)) - Log.~~ Log.field "domain" (toByteString' (tDomain lc)) - Log.~~ Log.msg - ( "An impossible federation error occurred when deleting\ - \ a user from a local conversation: " - <> displayException e - ) diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 78a319801db..df768732069 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -72,7 +72,6 @@ import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role import Wire.API.Error import Wire.API.Error.Galley -import Wire.API.Federation.Error import Wire.API.Provider.Service import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Public.Galley.LegalHold @@ -185,7 +184,6 @@ removeSettingsInternalPaging :: Member CodeStore r, Member ConversationStore r, Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'InvalidOperation) r, @@ -228,7 +226,6 @@ removeSettings :: Member CodeStore r, Member ConversationStore r, Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'InvalidOperation) r, @@ -290,7 +287,6 @@ removeSettings' :: Member BrigAccess r, Member CodeStore r, Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (Error AuthenticationError) r, Member (ErrorS 'NotATeamMember) r, @@ -380,7 +376,6 @@ getUserStatus _lzusr tid uid = do grantConsent :: ( Member BrigAccess r, Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -417,7 +412,6 @@ requestDevice :: forall db r. ( Member BrigAccess r, Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -497,7 +491,6 @@ approveDevice :: ( Member BrigAccess r, Member ConversationStore r, Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, @@ -576,7 +569,6 @@ disableForUser :: ( Member BrigAccess r, Member ConversationStore r, Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -632,7 +624,6 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = changeLegalholdStatus :: ( Member BrigAccess r, Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -748,7 +739,6 @@ unsetTeamLegalholdWhitelistedH tid = do -- one from the database. handleGroupConvPolicyConflicts :: ( Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member ExternalAccess r, diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index e744a7111ac..2b92bdb0d2c 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -27,6 +27,7 @@ module Galley.API.MLS.Message where import Control.Comonad +import Control.Error.Util (hush) import Control.Lens (preview) import Data.Id import Data.Json.Util @@ -59,7 +60,6 @@ import Galley.Effects.ProposalStore import Galley.Env import Galley.Options import Galley.Types.Conversations.Members -import Galley.Types.UserList import Imports import Polysemy import Polysemy.Error @@ -92,7 +92,6 @@ import Wire.API.MLS.SubConversation import Wire.API.MLS.Welcome import Wire.API.Message import Wire.API.Routes.Internal.Brig -import Wire.API.Unreachable import Wire.API.User.Client type MLSMessageStaticErrors = @@ -187,6 +186,8 @@ postMLSMessageFromLocalUser lusr mc conn smsg = do -- FUTUREWORK: Inline the body of 'postMLSMessageFromLocalUserV1' once version -- V1 is dropped assertMLSEnabled + -- (events, unreachables) <- postMLSMessageFromLocalUserV1 lusr mc conn msg + assertMLSEnabled (events, unreachables) <- case rmValue smsg of SomeMessage _ msg -> do qcnv <- getConversationIdByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound @@ -217,7 +218,7 @@ postMLSCommitBundle :: Qualified ConvId -> Maybe ConnId -> CommitBundle -> - Sem r ([LocalConversationUpdate], FailedToProcess) + Sem r ([LocalConversationUpdate], UnreachableUsers) postMLSCommitBundle loc qusr mc qcnv conn rawBundle = foldQualified loc @@ -275,7 +276,7 @@ postMLSCommitBundleToLocalConv :: Maybe ConnId -> CommitBundle -> Local ConvId -> - Sem r ([LocalConversationUpdate], FailedToProcess) + Sem r ([LocalConversationUpdate], UnreachableUsers) postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do let msg = rmValue (cbCommitMsg bundle) conv <- getLocalConvForUser qusr lcnv @@ -286,7 +287,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do senderClient <- fmap ciClient <$> getSenderIdentity qusr mc SMLSPlainText msg - (events, failedToProcess) <- case msgPayload msg of + events <- case msgPayload msg of CommitMessage commit -> do action <- getCommitData lconv mlsMeta (msgEpoch msg) commit @@ -297,7 +298,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do /= Set.fromList (map (snd . snd) (cmAssocs (paAdd action))) ) $ throwS @'MLSWelcomeMismatch - (updates, failedToProcess) <- + updates <- processCommitWithAction qusr senderClient @@ -310,7 +311,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do (msgSender msg) commit storeGroupInfoBundle lconv (cbGroupInfoBundle bundle) - pure (updates, failedToProcess) + pure updates ApplicationMessage _ -> throwS @'MLSUnsupportedMessage ProposalMessage _ -> throwS @'MLSUnsupportedMessage @@ -319,7 +320,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do for_ (cbWelcome bundle) $ postMLSWelcome lcnv conn - pure (events, failedToProcess <> failedToSendMaybe unreachables) + pure (events, unreachables) postMLSCommitBundleToRemoteConv :: ( Members MLSBundleStaticErrors r, @@ -338,7 +339,7 @@ postMLSCommitBundleToRemoteConv :: Maybe ConnId -> CommitBundle -> Remote ConvId -> - Sem r ([LocalConversationUpdate], FailedToProcess) + Sem r ([LocalConversationUpdate], UnreachableUsers) postMLSCommitBundleToRemoteConv loc qusr con bundle rcnv = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr @@ -392,7 +393,7 @@ postMLSMessage :: Qualified ConvId -> Maybe ConnId -> RawMLS SomeMessage -> - Sem r ([LocalConversationUpdate], FailedToProcess) + Sem r ([LocalConversationUpdate], UnreachableUsers) postMLSMessage loc qusr mc qcnv con smsg = case rmValue smsg of SomeMessage tag msg -> do @@ -470,7 +471,7 @@ postMLSMessageToLocalConv :: Maybe ConnId -> RawMLS SomeMessage -> Local ConvId -> - Sem r ([LocalConversationUpdate], FailedToProcess) + Sem r ([LocalConversationUpdate], UnreachableUsers) postMLSMessageToLocalConv qusr senderClient con smsg lcnv = case rmValue smsg of SomeMessage tag msg -> do @@ -482,13 +483,13 @@ postMLSMessageToLocalConv qusr senderClient con smsg lcnv = let lconv = qualifyAs lcnv conv -- validate message - (events, failedToProcess) <- case tag of + events <- case tag of SMLSPlainText -> case msgPayload msg of CommitMessage c -> processCommit qusr senderClient con lconv mlsMeta cm (msgEpoch msg) (msgSender msg) c ApplicationMessage _ -> throwS @'MLSUnsupportedMessage ProposalMessage prop -> - processProposal qusr conv mlsMeta msg prop $> (mempty, mempty) + processProposal qusr conv mlsMeta msg prop $> mempty SMLSCipherText -> case toMLSEnum' (msgContentType (msgPayload msg)) of Right CommitMessageTag -> throwS @'MLSUnsupportedMessage Right ProposalMessageTag -> throwS @'MLSUnsupportedMessage @@ -497,7 +498,7 @@ postMLSMessageToLocalConv qusr senderClient con smsg lcnv = -- forward message unreachables <- propagateMessage qusr lconv cm con (rmRaw smsg) - pure (events, failedToProcess <> failedToSendMaybe unreachables) + pure (events, unreachables) postMLSMessageToRemoteConv :: ( Members MLSMessageStaticErrors r, @@ -512,7 +513,7 @@ postMLSMessageToRemoteConv :: Maybe ConnId -> RawMLS SomeMessage -> Remote ConvId -> - Sem r ([LocalConversationUpdate], FailedToProcess) + Sem r ([LocalConversationUpdate], UnreachableUsers) postMLSMessageToRemoteConv loc qusr _senderClient con smsg rcnv = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr @@ -631,7 +632,7 @@ processCommit :: Epoch -> Sender 'MLSPlainText -> Commit -> - Sem r ([LocalConversationUpdate], FailedToProcess) + Sem r [LocalConversationUpdate] processCommit qusr senderClient con lconv mlsMeta cm epoch sender commit = do action <- getCommitData lconv mlsMeta epoch commit processCommitWithAction qusr senderClient con lconv mlsMeta cm epoch action sender commit @@ -766,13 +767,11 @@ processCommitWithAction :: ProposalAction -> Sender 'MLSPlainText -> Commit -> - Sem r ([LocalConversationUpdate], FailedToProcess) + Sem r [LocalConversationUpdate] processCommitWithAction qusr senderClient con lconv mlsMeta cm epoch action sender commit = case sender of MemberSender ref -> processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action ref commit - NewMemberSender -> - processExternalCommit qusr senderClient lconv mlsMeta cm epoch action (cPath commit) - $> (mempty, mempty) + NewMemberSender -> processExternalCommit qusr senderClient lconv mlsMeta cm epoch action (cPath commit) $> [] _ -> throw (mlsProtocolError "Unexpected sender") processInternalCommit :: @@ -796,7 +795,7 @@ processInternalCommit :: ProposalAction -> KeyPackageRef -> Commit -> - Sem r ([LocalConversationUpdate], FailedToProcess) + Sem r [LocalConversationUpdate] processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action senderRef commit = do self <- noteS @'ConvNotFound $ getConvMember lconv (tUnqualified lconv) qusr @@ -1110,7 +1109,7 @@ executeProposalAction :: ConversationMLSData -> ClientMap -> ProposalAction -> - Sem r ([LocalConversationUpdate], FailedToProcess) + Sem r [LocalConversationUpdate] executeProposalAction qusr con lconv mlsMeta cm action = do let ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta) newUserClients = Map.assocs (paAdd action) @@ -1124,71 +1123,53 @@ executeProposalAction qusr con lconv mlsMeta cm action = do -- Type 2 requires no special processing on the backend, so here we filter -- out all removals of that type, so that further checks and processing can -- be applied only to type 1 removals. - (failedRemoveFetching, removedUsers) <- - fmap partitionEithers $ forM (Map.assocs (paRemove action)) $ \(qtarget, Set.map fst -> clients) -> do + removedUsers <- mapMaybe hush <$$> for (Map.assocs (paRemove action)) $ + \(qtarget, Set.map fst -> clients) -> runError @() $ do -- fetch clients from brig - Set.map ciId <$$> getClientInfo lconv qtarget ss >>= \case - Left _ -> pure . Left $ qtarget - Right clientInfo -> do - -- if the clients being removed don't exist, consider this as a removal of - -- type 2, and skip it - pure $ - if Set.null (clientInfo `Set.intersection` clients) - then Left qtarget - else Right (qtarget, clients) + clientInfo <- Set.map ciId <$> getClientInfo lconv qtarget ss + -- if the clients being removed don't exist, consider this as a removal of + -- type 2, and skip it + when (Set.null (clientInfo `Set.intersection` clients)) $ + throw () + pure (qtarget, clients) -- FUTUREWORK: remove this check after remote admins are implemented in federation https://wearezeta.atlassian.net/browse/FS-216 foldQualified lconv (\_ -> pure ()) (\_ -> throwS @'MLSUnsupportedProposal) qusr -- for each user, we compare their clients with the ones being added to the conversation - failedAddFetching <- fmap catMaybes $ - forM newUserClients $ - \(qtarget, newclients) -> case Map.lookup qtarget cm of - -- user is already present, skip check in this case - Just _ -> do - -- new user - pure Nothing - Nothing -> do - -- final set of clients in the conversation - let clients = Set.map fst (newclients <> Map.findWithDefault mempty qtarget cm) - -- get list of mls clients from Brig (local or remote) - getClientInfo lconv qtarget ss >>= \case - Left _e -> pure (Just qtarget) - Right clientInfo -> do - let allClients = Set.map ciId clientInfo - let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo) - -- We check the following condition: - -- allMLSClients ⊆ clients ⊆ allClients - -- i.e. - -- - if a client has at least 1 key package, it has to be added - -- - if a client is being added, it has to still exist - -- - -- The reason why we can't simply check that clients == allMLSClients is - -- that a client with no remaining key packages might be added by a user - -- who just fetched its last key package. - unless - ( Set.isSubsetOf allMLSClients clients - && Set.isSubsetOf clients allClients - ) - $ do - -- FUTUREWORK: turn this error into a proper response - throwS @'MLSClientMismatch - pure Nothing + for_ newUserClients $ \(qtarget, newclients) -> case Map.lookup qtarget cm of + -- user is already present, skip check in this case + Just _ -> pure () + -- new user + Nothing -> do + -- final set of clients in the conversation + let clients = Set.map fst (newclients <> Map.findWithDefault mempty qtarget cm) + -- get list of mls clients from brig + clientInfo <- getClientInfo lconv qtarget ss + let allClients = Set.map ciId clientInfo + let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo) + -- We check the following condition: + -- allMLSClients ⊆ clients ⊆ allClients + -- i.e. + -- - if a client has at least 1 key package, it has to be added + -- - if a client is being added, it has to still exist + -- + -- The reason why we can't simply check that clients == allMLSClients is + -- that a client with no remaining key packages might be added by a user + -- who just fetched its last key package. + unless + ( Set.isSubsetOf allMLSClients clients + && Set.isSubsetOf clients allClients + ) + $ do + -- unless (Set.isSubsetOf allClients clients) $ do + -- FUTUREWORK: turn this error into a proper response + throwS @'MLSClientMismatch membersToRemove <- catMaybes <$> for removedUsers (uncurry checkRemoval) -- add users to the conversation and send events - addEvents <- - foldMap addMembers - . nonEmpty - . filter (\u -> u `notElem` failedAddFetching) - . fmap fst - $ newUserClients - let failedAdding = - ulAll lconv . uncurry ulDiff . both (toUserList lconv) $ - ( fst <$> newUserClients, - foldMap (onlyJoining . lcuEvent) . fst $ addEvents - ) + addEvents <- foldMap addMembers . nonEmpty . map fst $ newUserClients -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do @@ -1202,17 +1183,8 @@ executeProposalAction qusr con lconv mlsMeta cm action = do for_ (Map.assocs (paRemove action)) $ \(qtarget, clients) -> do removeMLSClients (cnvmlsGroupId mlsMeta) qtarget (Set.map fst clients) - let failedToProcess = - failedToAdd (failedAddFetching <> failedAdding) - <> snd addEvents - <> failedToRemove failedRemoveFetching - <> snd removeEvents - pure (fst addEvents <> fst removeEvents, failedToProcess) + pure (addEvents <> removeEvents) where - onlyJoining :: Event -> [Qualified UserId] - onlyJoining (evtData -> EdMembersJoin ms) = smQualifiedId <$> mMembers ms - onlyJoining _ = [] - checkRemoval :: Qualified UserId -> Set ClientId -> @@ -1238,13 +1210,13 @@ executeProposalAction qusr con lconv mlsMeta cm action = do existingMembers :: Set (Qualified UserId) existingMembers = existingLocalMembers <> existingRemoteMembers - addMembers :: NonEmpty (Qualified UserId) -> Sem r ([LocalConversationUpdate], FailedToProcess) + addMembers :: NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] addMembers = -- FUTUREWORK: update key package ref mapping to reflect conversation membership foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap (first pure) + . fmap pure . updateLocalConversationUnchecked @'ConversationJoinTag lconv qusr con . flip ConversationJoin roleNameWireMember ) @@ -1252,12 +1224,12 @@ executeProposalAction qusr con lconv mlsMeta cm action = do . filter (flip Set.notMember existingMembers) . toList - removeMembers :: NonEmpty (Qualified UserId) -> Sem r ([LocalConversationUpdate], FailedToProcess) + removeMembers :: NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] removeMembers = foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap (first pure) + . fmap pure . updateLocalConversationUnchecked @'ConversationRemoveMembersTag lconv qusr con ) . nonEmpty @@ -1274,18 +1246,17 @@ getClientInfo :: Local x -> Qualified UserId -> SignatureSchemeTag -> - Sem r (Either FederationError (Set ClientInfo)) -getClientInfo loc = - foldQualified loc (\lusr -> fmap Right . getLocalMLSClients lusr) getRemoteMLSClients + Sem r (Set ClientInfo) +getClientInfo loc = foldQualified loc getLocalMLSClients getRemoteMLSClients getRemoteMLSClients :: ( Member FederatorAccess r ) => Remote UserId -> SignatureSchemeTag -> - Sem r (Either FederationError (Set ClientInfo)) + Sem r (Set ClientInfo) getRemoteMLSClients rusr ss = do - runFederatedEither rusr $ + runFederated rusr $ fedClient @'Brig @"get-mls-clients" $ MLSClientsRequest { mcrUserId = tUnqualified rusr, diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 3da4edbca19..e3b5918bb40 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -44,8 +44,8 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error +import Wire.API.MLS.Message import Wire.API.Message -import Wire.API.Unreachable -- | Propagate a message. propagateMessage :: @@ -60,7 +60,7 @@ propagateMessage :: ClientMap -> Maybe ConnId -> ByteString -> - Sem r (Maybe UnreachableUsers) + Sem r UnreachableUsers propagateMessage qusr lconv cm con raw = do -- FUTUREWORK: check the epoch let lmems = Data.convLocalMembers . tUnqualified $ lconv @@ -80,7 +80,7 @@ propagateMessage qusr lconv cm con raw = do foldMap (uncurry mkPush) (lmems >>= localMemberMLSClients lcnv) -- send to remotes - unreachableFromList . concat + UnreachableUsers . concat <$$> traverse handleError <=< runFederatedConcurrentlyEither (map remoteMemberQualify rmems) $ \(tUnqualified -> rs) -> diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 85d87da6601..b5172a853f2 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -76,7 +76,6 @@ import Wire.API.Conversation.Role (Action (RemoveConversationMember)) import Wire.API.Error (ErrorS, throwS) import Wire.API.Error.Galley import qualified Wire.API.Event.FeatureConfig as Event -import Wire.API.Federation.Error import qualified Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi import Wire.API.Team.Feature import Wire.API.Team.Member @@ -698,7 +697,6 @@ instance SetFeatureConfig db LegalholdConfig where Member CodeStore r, Member ConversationStore r, Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'CannotEnableLegalHoldServiceLargeTeam) r, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 85d685593b1..2460533ccb3 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -288,7 +288,7 @@ updateConversationAccess :: Sem r (UpdateResult Event) updateConversationAccess lusr con qcnv update = do lcnv <- ensureLocal lusr qcnv - getUpdateResult . fmap (lcuEvent . fst) $ + getUpdateResult . fmap lcuEvent $ updateLocalConversation @'ConversationAccessDataTag lcnv (tUntagged lusr) (Just con) update updateConversationAccessUnqualified :: @@ -300,7 +300,7 @@ updateConversationAccessUnqualified :: ConversationAccessData -> Sem r (UpdateResult Event) updateConversationAccessUnqualified lusr con cnv update = - getUpdateResult . fmap (lcuEvent . fst) $ + getUpdateResult . fmap lcuEvent $ updateLocalConversation @'ConversationAccessDataTag (qualifyAs lusr cnv) (tUntagged lusr) @@ -331,7 +331,7 @@ updateConversationReceiptMode lusr zcon qcnv update = foldQualified lusr ( \lcnv -> - getUpdateResult . fmap (lcuEvent . fst) $ + getUpdateResult . fmap lcuEvent $ updateLocalConversation @'ConversationReceiptModeUpdateTag lcnv @@ -370,7 +370,7 @@ updateRemoteConversation rcnv lusr conn action = getUpdateResult $ do convUpdate <- case response of ConversationUpdateResponseNoChanges -> throw NoChanges ConversationUpdateResponseError err' -> rethrowErrors @(HasConversationActionGalleyErrors tag) err' - ConversationUpdateResponseUpdate (convUpdate, _failedToProcess) -> pure convUpdate + ConversationUpdateResponseUpdate convUpdate -> pure convUpdate onConversationUpdated (tDomain rcnv) convUpdate notifyRemoteConversationAction lusr (qualifyAs rcnv convUpdate) (Just conn) @@ -419,7 +419,7 @@ updateConversationMessageTimer lusr zcon qcnv update = foldQualified lusr ( \lcnv -> - lcuEvent . fst + lcuEvent <$> updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv @@ -469,7 +469,7 @@ deleteLocalConversation :: Local ConvId -> Sem r (UpdateResult Event) deleteLocalConversation lusr con lcnv = - getUpdateResult . fmap (lcuEvent . fst) $ + getUpdateResult . fmap lcuEvent $ updateLocalConversation @'ConversationDeleteTag lcnv (tUntagged lusr) (Just con) () getUpdateResult :: Sem (Error NoChanges ': r) a -> Sem r (UpdateResult a) @@ -675,7 +675,6 @@ joinConversationByReusableCode :: ( Member BrigAccess r, Member CodeStore r, Member ConversationStore r, - Member (Error FederationError) r, Member (ErrorS 'CodeNotFound) r, Member (ErrorS 'InvalidConversationPassword) r, Member (ErrorS 'ConvAccessDenied) r, @@ -710,7 +709,6 @@ joinConversationById :: ( Member BrigAccess r, Member FederatorAccess r, Member ConversationStore r, - Member (Error FederationError) r, Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, @@ -736,7 +734,6 @@ joinConversation :: forall r. ( Member BrigAccess r, Member FederatorAccess r, - Member (Error FederationError) r, Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, @@ -767,8 +764,9 @@ joinConversation lusr zcon conv access = do let users = filter (notIsConvMember lusr conv) [tUnqualified lusr] (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember - lcuEvent . fst + lcuEvent <$> notifyConversationAction + False (sing @'ConversationJoinTag) (tUntagged lusr) False @@ -810,7 +808,7 @@ addMembers :: Sem r (UpdateResult Event) addMembers lusr zcon qcnv (InviteQualified users role) = do lcnv <- ensureLocal lusr qcnv - getUpdateResult . fmap (lcuEvent . fst) $ + getUpdateResult . fmap lcuEvent $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role @@ -847,7 +845,7 @@ addMembersUnqualifiedV2 :: Sem r (UpdateResult Event) addMembersUnqualifiedV2 lusr zcon cnv (InviteQualified users role) = do let lcnv = qualifyAs lusr cnv - getUpdateResult . fmap (lcuEvent . fst) $ + getUpdateResult . fmap lcuEvent $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role @@ -952,7 +950,6 @@ updateUnqualifiedSelfMember lusr zcon cnv update = do updateOtherMemberLocalConv :: ( Member ConversationStore r, - Member (Error FederationError) r, Member (ErrorS ('ActionDenied 'ModifyOtherConversationMember)) r, Member (ErrorS 'InvalidTarget) r, Member (ErrorS 'InvalidOperation) r, @@ -971,7 +968,7 @@ updateOtherMemberLocalConv :: Qualified UserId -> OtherMemberUpdate -> Sem r () -updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult . fmap (lcuEvent . fst) $ do +updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult . fmap lcuEvent $ do when (tUntagged lusr == qvictim) $ throwS @'InvalidTarget updateLocalConversation @'ConversationMemberUpdateTag lcnv (tUntagged lusr) (Just con) $ @@ -979,7 +976,6 @@ updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult updateOtherMemberUnqualified :: ( Member ConversationStore r, - Member (Error FederationError) r, Member (ErrorS ('ActionDenied 'ModifyOtherConversationMember)) r, Member (ErrorS 'InvalidTarget) r, Member (ErrorS 'InvalidOperation) r, @@ -1040,7 +1036,6 @@ updateOtherMemberRemoteConv _ _ _ _ _ = throw FederationNotImplemented removeMemberUnqualified :: ( Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'ConvNotFound) r, @@ -1066,7 +1061,6 @@ removeMemberUnqualified lusr con cnv victim = do removeMemberQualified :: ( Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'ConvNotFound) r, @@ -1108,7 +1102,7 @@ removeMemberFromRemoteConv cnv lusr victim | tUntagged lusr == victim = do let lc = LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) let rpc = fedClient @'Galley @"leave-conversation" lc - (either handleError handleSuccess . void . leaveResponse =<<) $ + (either handleError handleSuccess . leaveResponse =<<) $ E.runFederated cnv rpc | otherwise = throwS @('ActionDenied 'RemoveConversationMember) where @@ -1133,7 +1127,6 @@ removeMemberFromRemoteConv cnv lusr victim -- | Remove a member from a local conversation. removeMemberFromLocalConv :: ( Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'LeaveConversation)) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, @@ -1155,12 +1148,12 @@ removeMemberFromLocalConv :: Sem r (Maybe Event) removeMemberFromLocalConv lcnv lusr con victim | tUntagged lusr == victim = - fmap (fmap lcuEvent . hush . fmap fst) + fmap (fmap lcuEvent . hush) . runError @NoChanges . updateLocalConversation @'ConversationLeaveTag lcnv (tUntagged lusr) con $ () | otherwise = - fmap (fmap lcuEvent . hush . fmap fst) + fmap (fmap lcuEvent . hush) . runError @NoChanges . updateLocalConversation @'ConversationRemoveMembersTag lcnv (tUntagged lusr) con . pure @@ -1346,7 +1339,6 @@ updateConversationName lusr zcon qcnv convRename = do updateUnqualifiedConversationName :: ( Member ConversationStore r, - Member (Error FederationError) r, Member (Error InvalidInput) r, Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, @@ -1368,7 +1360,6 @@ updateUnqualifiedConversationName lusr zcon cnv rename = do updateLocalConversationName :: ( Member ConversationStore r, - Member (Error FederationError) r, Member (Error InvalidInput) r, Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, @@ -1385,7 +1376,7 @@ updateLocalConversationName :: ConversationRename -> Sem r (UpdateResult Event) updateLocalConversationName lusr zcon lcnv rename = - getUpdateResult . fmap (lcuEvent . fst) $ + getUpdateResult . fmap lcuEvent $ updateLocalConversation @'ConversationRenameTag lcnv (tUntagged lusr) (Just zcon) rename memberTyping :: diff --git a/services/galley/src/Galley/Types/UserList.hs b/services/galley/src/Galley/Types/UserList.hs index 3dbc81444de..a4565da2c13 100644 --- a/services/galley/src/Galley/Types/UserList.hs +++ b/services/galley/src/Galley/Types/UserList.hs @@ -22,7 +22,6 @@ module Galley.Types.UserList ulAll, ulFromLocals, ulFromRemotes, - ulDiff, ) where @@ -57,10 +56,3 @@ ulFromLocals = flip UserList [] ulFromRemotes :: [Remote a] -> UserList a ulFromRemotes = UserList [] - --- | Remove from the first list all the users that are in the second list. -ulDiff :: Eq a => UserList a -> UserList a -> UserList a -ulDiff (UserList lA rA) (UserList lB rB) = - UserList - (filter (`notElem` lB) lA) - (filter (`notElem` rB) rA) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 62275b1d1ff..5689797051b 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2654,7 +2654,7 @@ testAddRemoteMember = do convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing let qconvId = Qualified convId localDomain - postQualifiedMembers alice (remoteBob :| []) qconvId !!! do + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 403 === statusCode const (Right (Just "not-connected")) === fmap (view (at "label")) . responseJsonEither @Object @@ -2662,7 +2662,7 @@ testAddRemoteMember = do (resp, reqs) <- withTempMockFederator' (respond remoteBob) $ - postQualifiedMembers alice (remoteBob :| []) qconvId + postQualifiedMembers alice (remoteBob :| []) convId postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing - let qconvId = Qualified convId localDomain + let _qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob @@ -2708,7 +2708,7 @@ testDeleteTeamConversationWithRemoteMembers = do ("on-new-remote-conversation" ~> EmptyResponse) <|> ("on-conversation-updated" ~> ()) (_, received) <- withTempMockFederator' mock $ do - postQualifiedMembers alice (remoteBob :| []) qconvId + postQualifiedMembers alice (remoteBob :| []) convId !!! const 200 === statusCode deleteTeamConv tid convId alice @@ -2734,7 +2734,6 @@ testDeleteTeamConversationWithUnavailableRemoteMembers = do remoteBob = Qualified bobId remoteDomain convId <- decodeConvId <$> postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing - let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob @@ -2744,11 +2743,11 @@ testDeleteTeamConversationWithUnavailableRemoteMembers = do <|> (guardRPC "on-conversation-updated" *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")) <|> (guardRPC "delete-team-conversation" *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")) (_, received) <- withTempMockFederator' mock $ do - postQualifiedMembers alice (remoteBob :| []) qconvId - !!! const 200 === statusCode + postQualifiedMembers alice (remoteBob :| []) convId + !!! const 503 === statusCode deleteTeamConv tid convId alice - !!! const 200 === statusCode + !!! const 503 === statusCode liftIO $ do let convUpdates = mapMaybe (eitherToMaybe . parseFedRequest) received convUpdate <- case filter ((== SomeConversationAction (sing @'ConversationDeleteTag) ()) . cuAction) convUpdates of @@ -2965,12 +2964,10 @@ testAddRemoteMemberInvalidDomain = do bobId <- randomId let remoteBob = Qualified bobId (Domain "invalid.example.com") convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing - localDomain <- viewFederationDomain - let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob - postQualifiedMembers alice (remoteBob :| []) qconvId + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 422 === statusCode const (Just "/federation/api-version") @@ -2985,13 +2982,14 @@ testAddRemoteMemberFederationDisabled = do alice <- randomUser remoteBob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId qconvId <- decodeQualifiedConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing + let convId = qUnqualified qconvId connectWithRemoteUser alice remoteBob -- federator endpoint not configured is equivalent to federation being disabled -- This is the case on staging/production in May 2021. let federatorNotConfigured = optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ - postQualifiedMembers alice (remoteBob :| []) qconvId !!! do + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 400 === statusCode const (Right "federation-not-enabled") === fmap label . responseJsonEither @@ -3004,6 +3002,7 @@ testAddRemoteMemberFederationUnavailable = do alice <- randomUser remoteBob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId qconvId <- decodeQualifiedConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing + let convId = qUnqualified qconvId connectWithRemoteUser alice remoteBob -- federator endpoint being configured in brig and/or galley, but not being @@ -3012,7 +3011,7 @@ testAddRemoteMemberFederationUnavailable = do -- Port 1 should always be wrong hopefully. let federatorUnavailable = optFederator ?~ Endpoint "127.0.0.1" 1 withSettingsOverrides federatorUnavailable $ - postQualifiedMembers alice (remoteBob :| []) qconvId !!! do + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 500 === statusCode const (Right "federation-not-available") === fmap label . responseJsonEither @@ -3349,7 +3348,7 @@ leaveRemoteConvQualifiedOk = do qBob = Qualified bob remoteDomain let mockedFederatedGalleyResponse = do guardComponent Galley - mockReply (F.LeaveConversationResponse (Right mempty)) + mockReply (F.LeaveConversationResponse (Right ())) mockResponses = mockedFederatedBrigResponse [(qBob, "Bob")] <|> mockedFederatedGalleyResponse @@ -3962,7 +3961,7 @@ putRemoteReceiptModeOk = do cuAction = SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) action } - let mockResponse = mockReply (ConversationUpdateResponseUpdate (responseConvUpdate, mempty)) + let mockResponse = mockReply (ConversationUpdateResponseUpdate responseConvUpdate) WS.bracketR c adam $ \wsAdam -> do (res, federatedRequests) <- withTempMockFederator' mockResponse $ do @@ -4238,7 +4237,7 @@ removeUser = do do guard (d `elem` [bDomain, cDomain]) asum - [ "leave-conversation" ~> F.LeaveConversationResponse (Right mempty), + [ "leave-conversation" ~> F.LeaveConversationResponse (Right ()), "on-conversation-updated" ~> () ] ] diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 4d897b0512a..f05cfe537e4 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -680,7 +680,7 @@ leaveConversationSuccess = do liftIO $ case resp of + cnvUpdate' <- liftIO $ case resp of ConversationUpdateResponseError err -> assertFailure ("Expected ConversationUpdateResponseUpdate but got " <> show err) ConversationUpdateResponseNoChanges -> assertFailure "Expected ConversationUpdateResponseUpdate but got ConversationUpdateResponseNoChanges" ConversationUpdateResponseUpdate up -> pure up diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index d1f8dbe9cfd..c6c1c2d3dbe 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -25,6 +25,7 @@ import API.Util import Bilge hiding (head) import Bilge.Assert import Cassandra hiding (Set) +import Control.Exception (throw) import Control.Lens (view) import Control.Lens.Extras import qualified Control.Monad.State as State @@ -37,7 +38,6 @@ import qualified Data.ByteString.Lazy as LBS import Data.Domain import Data.Id import Data.Json.Util hiding ((#)) -import qualified Data.List.NonEmpty as NE import Data.List1 hiding (head) import qualified Data.Map as Map import Data.Qualified @@ -49,6 +49,7 @@ import qualified Data.Text as T import Data.Time import Federator.MockServer hiding (withTempMockFederator) import Imports +import qualified Network.HTTP.Types.Status as HTTP import qualified Network.Wai.Utilities.Error as Wai import Test.QuickCheck (Arbitrary (arbitrary), generate) import Test.Tasty @@ -66,13 +67,13 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API.Galley import Wire.API.MLS.Credential import Wire.API.MLS.Keys +import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.MLS.Welcome import Wire.API.Message import Wire.API.Routes.MultiTablePaging import Wire.API.Routes.Version -import Wire.API.Unreachable tests :: IO TestSetup -> TestTree tests s = @@ -110,7 +111,6 @@ tests s = test s "add user with some non-MLS clients" testAddUserWithProteusClients, test s "send a stale commit" testStaleCommit, test s "add remote user to a conversation" testAddRemoteUser, - test s "add remote users to a conversation (some unreachable)" testAddRemotesSomeUnreachable, test s "return error when commit is locked" testCommitLock, test s "add user to a conversation with proposal + commit" testAddUserBareProposalCommit, test s "post commit that references an unknown proposal" testUnknownProposalRefCommit, @@ -663,61 +663,6 @@ testAddRemoteUser = do event <- assertOne events assertJoinEvent qcnv alice [bob] roleNameWireMember event -testAddRemotesSomeUnreachable :: TestM () -testAddRemotesSomeUnreachable = do - let bobDomain = Domain "bob.example.com" - charlieDomain = Domain "charlie.example.com" - users@[alice, bob, charlie] <- - createAndConnectUsers $ - domainText - <$$> [Nothing, Just bobDomain, Just charlieDomain] - (events, failedToProcess, reqs, qcnv) <- runMLSTest $ do - [alice1, bob1, _charlie1] <- traverse createMLSClient users - (_, qcnv) <- setupMLSGroup alice1 - - commit <- createAddCommit alice1 [bob, charlie] - let unreachable = Set.singleton charlieDomain - ((events, failedToProcess), reqs) <- - withTempMockFederator' - ( receiveCommitMockByDomain [bob1] - <|> mlsMockUnreachableFor unreachable - <|> welcomeMockByDomain [bobDomain] - ) - $ sendAndConsumeCommitFederated commit - pure (events, failedToProcess, reqs, qcnv) - - let expectedJoiners = [bob] - liftIO $ do - req <- - assertOne $ - filter - ( \r -> - ((== "on-conversation-updated") . frRPC) r - && frTargetDomain r == bobDomain - ) - reqs - frTargetDomain req @?= qDomain bob - bdy <- case Aeson.eitherDecode (frBody req) of - Right b -> pure b - Left e -> assertFailure $ "Could not parse on-conversation-updated request body: " <> e - cuOrigUserId bdy @?= alice - cuConvId bdy @?= qUnqualified qcnv - cuAlreadyPresentUsers bdy @?= [qUnqualified bob] - failedToProcess - @?= FailedToProcess - { send = Nothing, - add = unreachableFromList [charlie], - remove = Nothing - } - let SomeConversationAction SConversationJoinTag cj = cuAction bdy - ConversationJoin actualJoiners actualRole = cj - (sort . NE.toList) actualJoiners @?= expectedJoiners - actualRole @?= roleNameWireMember - - liftIO $ do - event <- assertOne events - assertJoinEvent qcnv alice expectedJoiners roleNameWireMember event - testCommitLock :: TestM () testCommitLock = do users <- createAndConnectUsers (replicate 4 Nothing) @@ -1166,11 +1111,12 @@ testAppMessage2 = do testAppMessageSomeReachable :: TestM () testAppMessageSomeReachable = do - let bobDomain = Domain "bob.example.com" - charlieDomain = Domain "charlie.example.com" users@[_alice, bob, charlie] <- - createAndConnectUsers $ - domainText <$$> [Nothing, Just bobDomain, Just charlieDomain] + createAndConnectUsers + [ Nothing, + Just "bob.example.com", + Just "charlie.example.com" + ] void $ runMLSTest $ do [alice1, bob1, charlie1] <- @@ -1179,25 +1125,27 @@ testAppMessageSomeReachable = do void $ setupMLSGroup alice1 commit <- createAddCommit alice1 [bob, charlie] - let commitMocks = + let mocks = receiveCommitMockByDomain [bob1, charlie1] <|> welcomeMock - (([event], ftpCommit), _) <- - withTempMockFederator' commitMocks $ do - sendAndConsumeCommitFederated commit - liftIO $ ftpCommit @?= mempty + ([event], _) <- + withTempMockFederator' mocks $ do + sendAndConsumeCommit commit let unreachables = Set.singleton (Domain "charlie.example.com") - let sendMocks = - messageSentMockByDomain [bobDomain] - <|> mlsMockUnreachableFor unreachables - - withTempMockFederator' sendMocks $ do + withTempMockFederator' (mockUnreachableFor unreachables) $ do message <- createApplicationMessage alice1 "hi, bob!" - (_, ftp) <- sendAndConsumeMessage message + (_, us) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - ftp @?= failedToSend [charlie] + us @?= UnreachableUsers [charlie] + where + mockUnreachableFor :: Set Domain -> Mock LByteString + mockUnreachableFor backends = do + r <- getRequest + if Set.member (frTargetDomain r) backends + then throw (MockErrorResponse HTTP.status503 "Down for maintenance.") + else mockReply ("RemoteMLSMessageOk" :: String) testAppMessageUnreachable :: TestM () testAppMessageUnreachable = do @@ -1216,10 +1164,10 @@ testAppMessageUnreachable = do sendAndConsumeCommit commit message <- createApplicationMessage alice1 "hi, bob!" - (_, ftp) <- sendAndConsumeMessage message + (_, us) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - ftp @?= failedToSend [bob] + us @?= UnreachableUsers [bob] testRemoteToRemote :: TestM () testRemoteToRemote = do @@ -2090,7 +2038,7 @@ testAddUserToRemoteConvWithBundle = do commit <- createAddCommit bob1 [charlie] commitBundle <- createBundle commit - let mock = "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] mempty + let mock = "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUsers []) (_, reqs) <- withTempMockFederator' mock $ do void $ sendAndConsumeCommitBundle commit diff --git a/services/galley/test/integration/API/MLS/Mocks.hs b/services/galley/test/integration/API/MLS/Mocks.hs index 903b830f907..911b3380537 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -19,17 +19,13 @@ module API.MLS.Mocks ( receiveCommitMock, receiveCommitMockByDomain, messageSentMock, - messageSentMockByDomain, welcomeMock, - welcomeMockByDomain, sendMessageMock, claimKeyPackagesMock, queryGroupStateMock, - mlsMockUnreachableFor, ) where -import Data.Domain import Data.Id import Data.Json.Util import Data.Qualified @@ -41,6 +37,7 @@ import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Message import Wire.API.User.Client receiveCommitMock :: [ClientIdentity] -> Mock LByteString @@ -56,35 +53,29 @@ receiveCommitMock clients = receiveCommitMockByDomain :: [ClientIdentity] -> Mock LByteString receiveCommitMockByDomain clients = do - domain <- frTargetDomain <$> getRequest - guard (domain `elem` (ciDomain <$> clients)) - let fClients = filter (\c -> domain == ciDomain c) clients - receiveCommitMock fClients + r <- getRequest + let fClients = filter (\c -> frTargetDomain r == ciDomain c) clients + asum + [ "on-conversation-updated" ~> (), + "on-new-remote-conversation" ~> EmptyResponse, + "get-mls-clients" ~> + Set.fromList + ( map (flip ClientInfo True . ciClient) fClients + ) + ] messageSentMock :: Mock LByteString messageSentMock = "on-mls-message-sent" ~> RemoteMLSMessageOk -messageSentMockByDomain :: [Domain] -> Mock LByteString -messageSentMockByDomain reachables = do - domain <- frTargetDomain <$> getRequest - guard (domain `elem` reachables) - messageSentMock - welcomeMock :: Mock LByteString welcomeMock = "mls-welcome" ~> MLSWelcomeSent -welcomeMockByDomain :: [Domain] -> Mock LByteString -welcomeMockByDomain reachables = do - domain <- frTargetDomain <$> getRequest - guard (domain `elem` reachables) - welcomeMock - sendMessageMock :: Mock LByteString sendMessageMock = "send-mls-message" ~> MLSMessageResponseUpdates [] - mempty + (UnreachableUsers []) claimKeyPackagesMock :: KeyPackageBundle -> Mock LByteString claimKeyPackagesMock kpb = "claim-key-packages" ~> kpb @@ -97,6 +88,3 @@ queryGroupStateMock gs qusr = do if uid == qUnqualified qusr then GetGroupInfoResponseState (Base64ByteString gs) else GetGroupInfoResponseError ConvNotFound - -mlsMockUnreachableFor :: Set Domain -> Mock LByteString -mlsMockUnreachableFor = mockUnreachableFor "RemoteMLSMessageOk" diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 2c14878c559..28f1a47d001 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -78,7 +78,6 @@ import Wire.API.MLS.Keys import Wire.API.MLS.Message import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation -import Wire.API.Unreachable import Wire.API.User.Client import Wire.API.User.Client.Prekey @@ -840,10 +839,10 @@ consumeMessage1 cid msg = do -- | Send an MLS message and simulate clients receiving it. If the message is a -- commit, the 'sendAndConsumeCommit' function should be used instead. -sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], FailedToProcess) +sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], UnreachableUsers) sendAndConsumeMessage mp = do res <- - fmap (mmssEvents Tuple.&&& mmssFailedToProcess) $ + fmap (mmssEvents Tuple.&&& mmssUnreachableUsers) $ responseJsonError =<< postMessage (mpSender mp) (mpMessage mp) MessagePackage -> MLSTest [Event] -sendAndConsumeCommit = fmap fst . sendAndConsumeCommitFederated - --- | Send an MLS commit message, simulate clients receiving it, and update the --- test state accordingly. Also return lists of federated users that a message --- could not be sent to. -sendAndConsumeCommitFederated :: - HasCallStack => - MessagePackage -> - MLSTest ([Event], FailedToProcess) -sendAndConsumeCommitFederated mp = do - resp <- sendAndConsumeMessage mp +sendAndConsumeCommit mp = do + (events, _) <- sendAndConsumeMessage mp -- increment epoch and add new clients State.modify $ \mls -> @@ -882,7 +872,7 @@ sendAndConsumeCommitFederated mp = do mlsNewMembers = mempty } - pure resp + pure events mkBundle :: MessagePackage -> Either Text CommitBundle mkBundle mp = do diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 7936d6b5cfa..1f568245f37 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -1074,7 +1074,7 @@ testNoConsentCannotBeInvited = do >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") localdomain <- viewFederationDomain - API.Util.postQualifiedMembers userLHNotActivated (Qualified peer2 localdomain :| []) qconvId + API.Util.postQualifiedMembers userLHNotActivated (Qualified peer2 localdomain :| []) convId >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") testCannotCreateGroupWithUsersInConflict :: HasCallStack => TestM () diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 6341179f8f2..1a0fcebce7a 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1142,22 +1142,17 @@ listRemoteConvs remoteDomain uid = do pure $ filter (\qcnv -> qDomain qcnv == remoteDomain) allConvs postQualifiedMembers :: - (MonadReader TestSetup m, MonadHttp m, HasGalley m) => + (MonadReader TestSetup m, MonadHttp m) => UserId -> NonEmpty (Qualified UserId) -> - Qualified ConvId -> + ConvId -> m ResponseLBS postQualifiedMembers zusr invitees conv = do - g <- viewGalley + g <- view tsUnversionedGalley let invite = InviteQualified invitees roleNameWireAdmin post $ g - . paths - [ "conversations", - toByteString' . qDomain $ conv, - toByteString' . qUnqualified $ conv, - "members" - ] + . paths ["v1", "conversations", toByteString' conv, "members", "v2"] . zUser zusr . zConn "conn" . zType "access" @@ -2314,8 +2309,8 @@ assertMismatchQualified :: Client.QualifiedUserClients -> Client.QualifiedUserClients -> Assertions () -assertMismatchQualified failureToSend missing redundant deleted = do - assertExpected "failed to send" failureToSend (fmap mssFailedToSend . responseJsonMaybe) +assertMismatchQualified failedToSend missing redundant deleted = do + assertExpected "failed to send" failedToSend (fmap mssFailedToSend . responseJsonMaybe) assertExpected "missing" missing (fmap mssMissingClients . responseJsonMaybe) assertExpected "redundant" redundant (fmap mssRedundantClients . responseJsonMaybe) assertExpected "deleted" deleted (fmap mssDeletedClients . responseJsonMaybe)