diff --git a/changelog.d/6-federation/failed-to-process b/changelog.d/6-federation/failed-to-process new file mode 100644 index 0000000000..e9a94f54b8 --- /dev/null +++ b/changelog.d/6-federation/failed-to-process @@ -0,0 +1 @@ +Several federation Galley endpoints have a breaking change in their response types: "leave-conversation", "update-conversation" and "send-mls-message". They have been extended with information related to unreachable users. 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 8a0422c5f2..51b1211183 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 ()} + {leaveResponse :: Either RemoveFromConversationError FailedToProcess} deriving stock (Eq, Show) deriving (ToJSON, FromJSON) - via (Either (CustomEncoded RemoveFromConversationError) ()) + via (Either (CustomEncoded RemoveFromConversationError) FailedToProcess) type UserDeletedNotificationMaxConvs = 1000 @@ -398,7 +398,7 @@ data ConversationUpdateRequest = ConversationUpdateRequest data ConversationUpdateResponse = ConversationUpdateResponseError GalleyError - | ConversationUpdateResponseUpdate ConversationUpdate + | ConversationUpdateResponseUpdate ConversationUpdate FailedToProcess | ConversationUpdateResponseNoChanges deriving stock (Eq, Show, Generic) deriving @@ -423,7 +423,7 @@ data MLSMessageResponse = MLSMessageResponseError GalleyError | MLSMessageResponseProtocolError Text | MLSMessageResponseProposalFailure Wai.Error - | MLSMessageResponseUpdates [ConversationUpdate] UnreachableUsers + | MLSMessageResponseUpdates [ConversationUpdate] (Maybe 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 5bc03b0398..0acf15af8b 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,7 +42,10 @@ spec = testObjects [ (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus1, "testObject_MLSMessageSendingStatus1.json"), (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus2, "testObject_MLSMessageSendingStatus2.json"), - (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus3, "testObject_MLSMessageSendingStatus3.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") ] 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 05137a2713..0620028b18 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 () +testObject_LeaveConversationResponse1 = LeaveConversationResponse $ Right mempty 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 0e228bec42..16226c28cf 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,13 +24,14 @@ 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"), - mmssUnreachableUsers = UnreachableUsers [] + mmssUnreachableUsers = mempty } testObject_MLSMessageSendingStatus2 :: MLSMessageSendingStatus @@ -38,7 +39,7 @@ testObject_MLSMessageSendingStatus2 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "2001-04-12 12:22:43.673 UTC"), - mmssUnreachableUsers = failed1 + mmssUnreachableUsers = unreachableFromList failed1 } testObject_MLSMessageSendingStatus3 :: MLSMessageSendingStatus @@ -46,18 +47,42 @@ testObject_MLSMessageSendingStatus3 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "1999-04-12 12:22:43.673 UTC"), - mmssUnreachableUsers = failed2 + mmssUnreachableUsers = unreachableFromList failed2 } -failed1 :: UnreachableUsers +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 + } + +failed1 :: [Qualified UserId] failed1 = let domain = Domain "offline.example.com" - in UnreachableUsers [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] + in [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] -failed2 :: UnreachableUsers +failed2 :: [Qualified UserId] failed2 = let domain = Domain "golden.example.com" - in UnreachableUsers - [ Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain, - Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000100000007") domain - ] + in flip Qualified domain . Id . fromJust . UUID.fromString + <$> [ "00000000-0000-0000-0000-000200000008", + "00000000-0000-0000-0000-000100000007" + ] diff --git a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json index 5ce20f1d24..31e2f71f18 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 9323f7742e..dcd87fe946 100644 --- a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json @@ -1,5 +1,4 @@ { - "events": [], - "time": "1864-04-12T12:22:43.673Z", - "failed_to_send": [] -} + "events": [], + "time": "1864-04-12T12:22:43.673Z" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json new file mode 100644 index 0000000000..ecc3d04f8a --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json @@ -0,0 +1,10 @@ +{ + "events": [], + "failed_to_send": [ + { + "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 new file mode 100644 index 0000000000..44d6fbdb7c --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json @@ -0,0 +1,14 @@ +{ + "events": [], + "failed_to_send": [ + { + "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 new file mode 100644 index 0000000000..cad9aa0d9a --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json @@ -0,0 +1,18 @@ +{ + "events": [], + "failed_to_send": [ + { + "domain": "offline.example.com", + "id": "00000000-0000-0000-0000-000200000008" + }, + { + "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 1787ceab4b..cfeae25018 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -37,7 +37,6 @@ module Wire.API.MLS.Message MLSCipherTextSym0, MLSMessageSendingStatus (..), KnownFormatTag (..), - UnreachableUsers (..), verifyMessageSignature, mkSignedMessage, ) @@ -50,10 +49,8 @@ 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 @@ -67,6 +64,7 @@ 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 @@ -318,22 +316,10 @@ 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, - mmssUnreachableUsers :: UnreachableUsers + mmssUnreachableUsers :: Maybe UnreachableUsers } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema MLSMessageSendingStatus @@ -353,10 +339,12 @@ instance ToSchema MLSMessageSendingStatus where (description ?~ "The time of sending the message.") schema <*> mmssUnreachableUsers - .= fieldWithDocModifier - "failed_to_send" - (description ?~ "List of federated users who could not be reached and did not receive the message") - schema + .= maybe_ + ( optFieldWithDocModifier + "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 new file mode 100644 index 0000000000..69725e53d0 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Unreachable.hs @@ -0,0 +1,127 @@ +-- 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 4e8d105456..099ac029fa 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -138,6 +138,7 @@ 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 f8f88e5310..ed40cc9d95 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -28,6 +28,7 @@ module Federator.MockServer Mock, runMock, mockReply, + mockUnreachableFor, mockFail, guardRPC, guardComponent, @@ -45,6 +46,7 @@ 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 @@ -203,6 +205,16 @@ 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 95cae36a04..4412315df3 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -37,7 +37,6 @@ module Galley.API.Action notifyConversationAction, notifyRemoteConversationAction, ConversationUpdate, - FederationFailEarly (..), ) where @@ -79,6 +78,8 @@ 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 @@ -98,6 +99,7 @@ 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 @@ -291,7 +293,8 @@ ensureAllowed tag loc action conv origUser = do -- and also returns the (possible modified) action that was performed performAction :: forall tag r. - ( HasConversationActionEffects tag r + ( HasConversationActionEffects tag r, + Member (Error FederationError) r ) => Sing tag -> Qualified UserId -> @@ -422,7 +425,8 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do ensureConnectedToRemotes lusr remotes checkLHPolicyConflictsLocal :: - ( Member (Error InternalError) r, + ( Member (Error FederationError) r, + Member (Error InternalError) r, Member (ErrorS 'MissingLegalholdConsent) r, Member ExternalAccess r, Member FederatorAccess r, @@ -477,7 +481,8 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do checkLHPolicyConflictsRemote _remotes = pure () performConversationAccessData :: - ( HasConversationActionEffects 'ConversationAccessDataTag r + ( HasConversationActionEffects 'ConversationAccessDataTag r, + Member (Error FederationError) r ) => Qualified UserId -> Local Conversation -> @@ -564,6 +569,7 @@ 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, @@ -579,7 +585,7 @@ updateLocalConversation :: Qualified UserId -> Maybe ConnId -> ConversationAction tag -> - Sem r LocalConversationUpdate + Sem r (LocalConversationUpdate, FailedToProcess) updateLocalConversation lcnv qusr con action = do let tag = sing @tag @@ -603,6 +609,7 @@ 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, @@ -617,7 +624,7 @@ updateLocalConversationUnchecked :: Qualified UserId -> Maybe ConnId -> ConversationAction tag -> - Sem r LocalConversationUpdate + Sem r (LocalConversationUpdate, FailedToProcess) updateLocalConversationUnchecked lconv qusr con action = do let tag = sing @tag lcnv = fmap convId lconv @@ -633,17 +640,6 @@ updateLocalConversationUnchecked lconv qusr con action = do (extraTargets, action') <- performAction tag qusr lconv action notifyConversationAction - ( case tag of - -- Removing members should be fault tolerant. - SConversationRemoveMembersTag -> FaultTolerant - -- Conversation metadata updates should be fault tolerant. - SConversationRenameTag -> FaultTolerant - SConversationMessageTimerUpdateTag -> FaultTolerant - SConversationReceiptModeUpdateTag -> FaultTolerant - SConversationAccessDataTag -> FaultTolerant - SConversationMemberUpdateTag -> FaultTolerant - _ -> FailEarly - ) (sing @tag) qusr False @@ -696,20 +692,15 @@ addMembersToLocalConversation lcnv users role = do let action = ConversationJoin neUsers role pure (bmFromMembers lmems rmems, action) -data FederationFailEarly - = FailEarly - | FaultTolerant - deriving (Eq, Show) - notifyConversationAction :: forall tag r. - ( Member FederatorAccess r, + ( Member (Error FederationError) r, + Member FederatorAccess r, Member ExternalAccess r, Member GundeckAccess r, Member (Input UTCTime) r, Member (Logger (Log.Msg -> Log.Msg)) r ) => - FederationFailEarly -> Sing tag -> Qualified UserId -> Bool -> @@ -717,8 +708,8 @@ notifyConversationAction :: Local Conversation -> BotsAndMembers -> ConversationAction (tag :: ConversationActionTag) -> - Sem r LocalConversationUpdate -notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets action = do + Sem r (LocalConversationUpdate, FailedToProcess) +notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do now <- input let lcnv = fmap convId lconv conv = tUnqualified lconv @@ -738,60 +729,68 @@ notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets a 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 } - 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 <- case failEarly of - FailEarly -> errorIntolerant - FaultTolerant -> errorTolerant + (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) -- 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 + pure $ (LocalConversationUpdate e update, failedToProcess) 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 $ @@ -847,7 +846,8 @@ notifyRemoteConversationAction loc rconvUpdate con = do -- leave, but then sends notifications as if the user was removed by someone -- else. kickMember :: - ( Member (Error InternalError) r, + ( Member (Error FederationError) r, + Member (Error InternalError) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, @@ -870,7 +870,6 @@ kickMember qusr lconv targets victim = void . runError @NoChanges $ do lconv () notifyConversationAction - FaultTolerant (sing @'ConversationRemoveMembersTag) qusr True diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index a03cdb2c51..68a28cd1ee 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -24,6 +24,7 @@ import Control.Lens (itraversed, preview, to, (<.>)) import Data.Bifunctor import Data.ByteString.Conversion (toByteString') import Data.Domain (Domain) +import Data.Either.Combinators import Data.Id import Data.Json.Util import qualified Data.Map as Map @@ -245,7 +246,7 @@ leaveConversation :: F.LeaveConversationRequest -> Sem r F.LeaveConversationResponse leaveConversation requestingDomain lc = do - let leaver :: Remote UserId = qTagUnsafe $ Qualified (F.lcLeaver lc) requestingDomain + let leaver = Qualified (F.lcLeaver lc) requestingDomain lcnv <- qualifyLocal (F.lcConvId lc) res <- @@ -255,34 +256,48 @@ leaveConversation requestingDomain lc = do . mapToRuntimeError @'InvalidOperation F.RemoveFromConversationErrorRemovalNotAllowed . mapError @NoChanges (const F.RemoveFromConversationErrorUnchanged) $ do - (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound (tUntagged leaver) lcnv - update <- - lcuUpdate - <$> updateLocalConversation - @'ConversationLeaveTag - lcnv - (tUntagged leaver) - Nothing - () - pure (update, conv) + (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) case res of Left e -> pure $ F.LeaveConversationResponse (Left e) - Right (_update, conv) -> do - let remotes = filter ((== tDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) + Right ((_update, updateFailedToProcess), conv) -> do + let remotes = filter ((== qDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) let botsAndMembers = BotsAndMembers mempty (Set.fromList remotes) mempty - _ <- - notifyConversationAction - FaultTolerant - SConversationLeaveTag - (tUntagged leaver) - False - Nothing - (qualifyAs lcnv conv) - botsAndMembers - () - - pure $ F.LeaveConversationResponse (Right ()) + (_, 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 -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients @@ -399,16 +414,17 @@ onUserDeleted origDomain udcn = do Public.RegularConv -> do let botsAndMembers = convBotsAndMembers conv removeUser (qualifyAs lc conv) (tUntagged deletedUser) - void $ - notifyConversationAction - FaultTolerant - (sing @'ConversationLeaveTag) - untaggedDeletedUser - False - Nothing - (qualifyAs lc conv) - botsAndMembers - () + outcome <- + runError @FederationError $ + notifyConversationAction + (sing @'ConversationLeaveTag) + untaggedDeletedUser + False + Nothing + (qualifyAs lc conv) + botsAndMembers + () + whenLeft outcome . logFederationError $ lc pure EmptyResponse updateConversation :: @@ -446,53 +462,53 @@ updateConversation origDomain updateRequest = do SomeConversationAction tag action -> case tag of SConversationJoinTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationJoinTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged rusr) Nothing action SConversationLeaveTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationLeaveTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationLeaveTag lcnv (tUntagged rusr) Nothing action SConversationRemoveMembersTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationRemoveMembersTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationRemoveMembersTag lcnv (tUntagged rusr) Nothing action SConversationMemberUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationMemberUpdateTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationMemberUpdateTag lcnv (tUntagged rusr) Nothing action SConversationDeleteTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationDeleteTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationDeleteTag lcnv (tUntagged rusr) Nothing action SConversationRenameTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationRenameTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationRenameTag lcnv (tUntagged rusr) Nothing action SConversationMessageTimerUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationMessageTimerUpdateTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv (tUntagged rusr) Nothing action SConversationReceiptModeUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationReceiptModeUpdateTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationReceiptModeUpdateTag lcnv (tUntagged rusr) Nothing action SConversationAccessDataTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationAccessDataTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationAccessDataTag lcnv (tUntagged rusr) Nothing action where mkResponse = fmap toResponse . runError @GalleyError . runError @NoChanges toResponse (Left galleyErr) = F.ConversationUpdateResponseError galleyErr toResponse (Right (Left NoChanges)) = F.ConversationUpdateResponseNoChanges - toResponse (Right (Right update)) = F.ConversationUpdateResponseUpdate update + toResponse (Right (Right (update, ftp))) = F.ConversationUpdateResponseUpdate update ftp sendMLSCommitBundle :: ( Member BrigAccess r, @@ -731,3 +747,24 @@ 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 df76873206..78a319801d 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -72,6 +72,7 @@ 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 @@ -184,6 +185,7 @@ 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, @@ -226,6 +228,7 @@ 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, @@ -287,6 +290,7 @@ 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, @@ -376,6 +380,7 @@ 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, @@ -412,6 +417,7 @@ 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, @@ -491,6 +497,7 @@ 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, @@ -569,6 +576,7 @@ 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, @@ -624,6 +632,7 @@ 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, @@ -739,6 +748,7 @@ 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 2b92bdb0d2..9cf8b55e84 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -92,6 +92,7 @@ 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 = @@ -186,8 +187,6 @@ 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 @@ -218,7 +217,7 @@ postMLSCommitBundle :: Qualified ConvId -> Maybe ConnId -> CommitBundle -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) postMLSCommitBundle loc qusr mc qcnv conn rawBundle = foldQualified loc @@ -276,7 +275,7 @@ postMLSCommitBundleToLocalConv :: Maybe ConnId -> CommitBundle -> Local ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do let msg = rmValue (cbCommitMsg bundle) conv <- getLocalConvForUser qusr lcnv @@ -339,7 +338,7 @@ postMLSCommitBundleToRemoteConv :: Maybe ConnId -> CommitBundle -> Remote ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) postMLSCommitBundleToRemoteConv loc qusr con bundle rcnv = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr @@ -393,7 +392,7 @@ postMLSMessage :: Qualified ConvId -> Maybe ConnId -> RawMLS SomeMessage -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) postMLSMessage loc qusr mc qcnv con smsg = case rmValue smsg of SomeMessage tag msg -> do @@ -471,7 +470,7 @@ postMLSMessageToLocalConv :: Maybe ConnId -> RawMLS SomeMessage -> Local ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) postMLSMessageToLocalConv qusr senderClient con smsg lcnv = case rmValue smsg of SomeMessage tag msg -> do @@ -513,7 +512,7 @@ postMLSMessageToRemoteConv :: Maybe ConnId -> RawMLS SomeMessage -> Remote ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe 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 @@ -1216,7 +1215,7 @@ executeProposalAction qusr con lconv mlsMeta cm action = do foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap pure + . fmap (pure . fst) . updateLocalConversationUnchecked @'ConversationJoinTag lconv qusr con . flip ConversationJoin roleNameWireMember ) @@ -1229,7 +1228,7 @@ executeProposalAction qusr con lconv mlsMeta cm action = do foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap pure + . fmap (pure . fst) . updateLocalConversationUnchecked @'ConversationRemoveMembersTag lconv qusr con ) . nonEmpty diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index e3b5918bb4..3da4edbca1 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 UnreachableUsers + Sem r (Maybe 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 - UnreachableUsers . concat + unreachableFromList . 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 b5172a853f..85d87da660 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -76,6 +76,7 @@ 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 @@ -697,6 +698,7 @@ 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 b97eac005c..2a36c40cfe 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -299,7 +299,7 @@ updateConversationAccess :: Sem r (UpdateResult Event) updateConversationAccess lusr con qcnv update = do lcnv <- ensureLocal lusr qcnv - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationAccessDataTag lcnv (tUntagged lusr) (Just con) update updateConversationAccessUnqualified :: @@ -311,7 +311,7 @@ updateConversationAccessUnqualified :: ConversationAccessData -> Sem r (UpdateResult Event) updateConversationAccessUnqualified lusr con cnv update = - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationAccessDataTag (qualifyAs lusr cnv) (tUntagged lusr) @@ -342,7 +342,7 @@ updateConversationReceiptMode lusr zcon qcnv update = foldQualified lusr ( \lcnv -> - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationReceiptModeUpdateTag lcnv @@ -381,7 +381,7 @@ updateRemoteConversation rcnv lusr conn action = getUpdateResult $ do convUpdate <- case response of ConversationUpdateResponseNoChanges -> throw NoChanges ConversationUpdateResponseError err' -> rethrowErrors @(HasConversationActionGalleyErrors tag) err' - ConversationUpdateResponseUpdate convUpdate -> pure convUpdate + ConversationUpdateResponseUpdate convUpdate _failedToProcess -> pure convUpdate updateLocalStateOfRemoteConv (tDomain rcnv) convUpdate notifyRemoteConversationAction lusr (qualifyAs rcnv convUpdate) (Just conn) @@ -430,7 +430,7 @@ updateConversationMessageTimer lusr zcon qcnv update = foldQualified lusr ( \lcnv -> - lcuEvent + lcuEvent . fst <$> updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv @@ -480,7 +480,7 @@ deleteLocalConversation :: Local ConvId -> Sem r (UpdateResult Event) deleteLocalConversation lusr con lcnv = - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationDeleteTag lcnv (tUntagged lusr) (Just con) () getUpdateResult :: Sem (Error NoChanges ': r) a -> Sem r (UpdateResult a) @@ -686,6 +686,7 @@ 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, @@ -720,6 +721,7 @@ 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, @@ -745,6 +747,7 @@ 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, @@ -775,9 +778,8 @@ joinConversation lusr zcon conv access = do let users = filter (notIsConvMember lusr conv) [tUnqualified lusr] (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember - lcuEvent + lcuEvent . fst <$> notifyConversationAction - FaultTolerant (sing @'ConversationJoinTag) (tUntagged lusr) False @@ -819,7 +821,7 @@ addMembers :: Sem r (UpdateResult Event) addMembers lusr zcon qcnv (InviteQualified users role) = do lcnv <- ensureLocal lusr qcnv - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role @@ -856,7 +858,7 @@ addMembersUnqualifiedV2 :: Sem r (UpdateResult Event) addMembersUnqualifiedV2 lusr zcon cnv (InviteQualified users role) = do let lcnv = qualifyAs lusr cnv - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role @@ -961,6 +963,7 @@ 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, @@ -979,7 +982,7 @@ updateOtherMemberLocalConv :: Qualified UserId -> OtherMemberUpdate -> Sem r () -updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult . fmap lcuEvent $ do +updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult . fmap (lcuEvent . fst) $ do when (tUntagged lusr == qvictim) $ throwS @'InvalidTarget updateLocalConversation @'ConversationMemberUpdateTag lcnv (tUntagged lusr) (Just con) $ @@ -987,6 +990,7 @@ 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, @@ -1047,6 +1051,7 @@ updateOtherMemberRemoteConv _ _ _ _ _ = throw FederationNotImplemented removeMemberUnqualified :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'ConvNotFound) r, @@ -1072,6 +1077,7 @@ 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, @@ -1113,7 +1119,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 . leaveResponse =<<) $ + (either handleError handleSuccess . void . leaveResponse =<<) $ E.runFederated cnv rpc | otherwise = throwS @('ActionDenied 'RemoveConversationMember) where @@ -1138,6 +1144,7 @@ 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, @@ -1159,12 +1166,12 @@ removeMemberFromLocalConv :: Sem r (Maybe Event) removeMemberFromLocalConv lcnv lusr con victim | tUntagged lusr == victim = - fmap (fmap lcuEvent . hush) + fmap (fmap lcuEvent . hush . fmap fst) . runError @NoChanges . updateLocalConversation @'ConversationLeaveTag lcnv (tUntagged lusr) con $ () | otherwise = - fmap (fmap lcuEvent . hush) + fmap (fmap lcuEvent . hush . fmap fst) . runError @NoChanges . updateLocalConversation @'ConversationRemoveMembersTag lcnv (tUntagged lusr) con . pure @@ -1350,6 +1357,7 @@ 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, @@ -1371,6 +1379,7 @@ 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, @@ -1387,7 +1396,7 @@ updateLocalConversationName :: ConversationRename -> Sem r (UpdateResult Event) updateLocalConversationName lusr zcon lcnv rename = - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ 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 a4565da2c1..3dbc81444d 100644 --- a/services/galley/src/Galley/Types/UserList.hs +++ b/services/galley/src/Galley/Types/UserList.hs @@ -22,6 +22,7 @@ module Galley.Types.UserList ulAll, ulFromLocals, ulFromRemotes, + ulDiff, ) where @@ -56,3 +57,10 @@ 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 4d2d6242ac..4af4a9bc60 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2741,7 +2741,7 @@ testAddRemoteMember = do convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing let qconvId = Qualified convId localDomain - postQualifiedMembers alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 403 === statusCode const (Right (Just "not-connected")) === fmap (view (at "label")) . responseJsonEither @Object @@ -2749,7 +2749,7 @@ testAddRemoteMember = do (resp, reqs) <- withTempMockFederator' (respond remoteBob) $ - postQualifiedMembers alice (remoteBob :| []) convId + postQualifiedMembers alice (remoteBob :| []) qconvId postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing - let _qconvId = Qualified convId localDomain + let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob @@ -2795,7 +2795,7 @@ testDeleteTeamConversationWithRemoteMembers = do ("on-new-remote-conversation" ~> EmptyResponse) <|> ("on-conversation-updated" ~> ()) (_, received) <- withTempMockFederator' mock $ do - postQualifiedMembers alice (remoteBob :| []) convId + postQualifiedMembers alice (remoteBob :| []) qconvId !!! const 200 === statusCode deleteTeamConv tid convId alice @@ -2821,6 +2821,7 @@ testDeleteTeamConversationWithUnavailableRemoteMembers = do remoteBob = Qualified bobId remoteDomain convId <- decodeConvId <$> postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing + let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob @@ -2830,11 +2831,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 :| []) convId - !!! const 503 === statusCode + postQualifiedMembers alice (remoteBob :| []) qconvId + !!! const 200 === statusCode deleteTeamConv tid convId alice - !!! const 503 === statusCode + !!! const 200 === statusCode liftIO $ do let convUpdates = mapMaybe (eitherToMaybe . parseFedRequest) received convUpdate <- case filter ((== SomeConversationAction (sing @'ConversationDeleteTag) ()) . cuAction) convUpdates of @@ -3051,10 +3052,12 @@ 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 :| []) convId + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 422 === statusCode const (Just "/federation/api-version") @@ -3069,14 +3072,13 @@ 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 :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 400 === statusCode const (Right "federation-not-enabled") === fmap label . responseJsonEither @@ -3089,7 +3091,6 @@ 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 @@ -3098,7 +3099,7 @@ testAddRemoteMemberFederationUnavailable = do -- Port 1 should always be wrong hopefully. let federatorUnavailable = optFederator ?~ Endpoint "127.0.0.1" 1 withSettingsOverrides federatorUnavailable $ - postQualifiedMembers alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 500 === statusCode const (Right "federation-not-available") === fmap label . responseJsonEither @@ -3435,7 +3436,7 @@ leaveRemoteConvQualifiedOk = do qBob = Qualified bob remoteDomain let mockedFederatedGalleyResponse = do guardComponent Galley - mockReply (F.LeaveConversationResponse (Right ())) + mockReply (F.LeaveConversationResponse (Right mempty)) mockResponses = mockedFederatedBrigResponse [(qBob, "Bob")] <|> mockedFederatedGalleyResponse @@ -4088,7 +4089,7 @@ putRemoteReceiptModeOk = do cuAction = SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) action } - let mockResponse = mockReply (ConversationUpdateResponseUpdate responseConvUpdate) + let mockResponse = mockReply (ConversationUpdateResponseUpdate responseConvUpdate mempty) WS.bracketR c adam $ \wsAdam -> do (res, federatedRequests) <- withTempMockFederator' mockResponse $ do @@ -4406,7 +4407,7 @@ removeUser = do do guard (d `elem` [bDomain, cDomain]) asum - [ "leave-conversation" ~> F.LeaveConversationResponse (Right ()), + [ "leave-conversation" ~> F.LeaveConversationResponse (Right mempty), "on-conversation-updated" ~> () ] ] diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index d0e6fe37a9..d65fa2d10e 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -762,7 +762,7 @@ leaveConversationSuccess = do assertFailure ("Expected ConversationUpdateResponseUpdate but got " <> show err) ConversationUpdateResponseNoChanges -> assertFailure "Expected ConversationUpdateResponseUpdate but got ConversationUpdateResponseNoChanges" - ConversationUpdateResponseUpdate up -> pure up + ConversationUpdateResponseUpdate up _ftp -> pure up liftIO $ do cuOrigUserId cnvUpdate' @?= qbob diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index c6c1c2d3db..3f78c2dfd1 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -25,7 +25,6 @@ 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 @@ -49,7 +48,6 @@ 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 @@ -67,13 +65,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 = @@ -1111,12 +1109,11 @@ testAppMessage2 = do testAppMessageSomeReachable :: TestM () testAppMessageSomeReachable = do + let bobDomain = Domain "bob.example.com" + charlieDomain = Domain "charlie.example.com" users@[_alice, bob, charlie] <- - createAndConnectUsers - [ Nothing, - Just "bob.example.com", - Just "charlie.example.com" - ] + createAndConnectUsers $ + domainText <$$> [Nothing, Just bobDomain, Just charlieDomain] void $ runMLSTest $ do [alice1, bob1, charlie1] <- @@ -1125,27 +1122,25 @@ testAppMessageSomeReachable = do void $ setupMLSGroup alice1 commit <- createAddCommit alice1 [bob, charlie] - let mocks = + let commitMocks = receiveCommitMockByDomain [bob1, charlie1] <|> welcomeMock - ([event], _) <- - withTempMockFederator' mocks $ do - sendAndConsumeCommit commit + (([event], ftpCommit), _) <- + withTempMockFederator' commitMocks $ do + sendAndConsumeCommitFederated commit + liftIO $ ftpCommit @?= mempty let unreachables = Set.singleton (Domain "charlie.example.com") - withTempMockFederator' (mockUnreachableFor unreachables) $ do + let sendMocks = + messageSentMockByDomain [bobDomain] + <|> mlsMockUnreachableFor unreachables + + withTempMockFederator' sendMocks $ do message <- createApplicationMessage alice1 "hi, bob!" - (_, us) <- sendAndConsumeMessage message + (_, ftp) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - 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) + ftp @?= unreachableFromList [charlie] testAppMessageUnreachable :: TestM () testAppMessageUnreachable = do @@ -1164,10 +1159,10 @@ testAppMessageUnreachable = do sendAndConsumeCommit commit message <- createApplicationMessage alice1 "hi, bob!" - (_, us) <- sendAndConsumeMessage message + (_, ftp) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - us @?= UnreachableUsers [bob] + ftp @?= unreachableFromList [bob] testRemoteToRemote :: TestM () testRemoteToRemote = do @@ -2038,7 +2033,7 @@ testAddUserToRemoteConvWithBundle = do commit <- createAddCommit bob1 [charlie] commitBundle <- createBundle commit - let mock = "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUsers []) + let mock = "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] mempty (_, 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 911b338053..903b830f90 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -19,13 +19,17 @@ 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 @@ -37,7 +41,6 @@ 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 @@ -53,29 +56,35 @@ receiveCommitMock clients = receiveCommitMockByDomain :: [ClientIdentity] -> Mock LByteString receiveCommitMockByDomain clients = do - 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 - ) - ] + domain <- frTargetDomain <$> getRequest + guard (domain `elem` (ciDomain <$> clients)) + let fClients = filter (\c -> domain == ciDomain c) clients + receiveCommitMock 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 [] - (UnreachableUsers []) + mempty claimKeyPackagesMock :: KeyPackageBundle -> Mock LByteString claimKeyPackagesMock kpb = "claim-key-packages" ~> kpb @@ -88,3 +97,6 @@ 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 28f1a47d00..a19829b45b 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -78,6 +78,7 @@ 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 @@ -839,7 +840,7 @@ 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], UnreachableUsers) +sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], Maybe UnreachableUsers) sendAndConsumeMessage mp = do res <- fmap (mmssEvents Tuple.&&& mmssUnreachableUsers) $ @@ -861,8 +862,17 @@ sendAndConsumeCommit :: HasCallStack => MessagePackage -> MLSTest [Event] -sendAndConsumeCommit mp = do - (events, _) <- sendAndConsumeMessage mp +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], Maybe UnreachableUsers) +sendAndConsumeCommitFederated mp = do + resp <- sendAndConsumeMessage mp -- increment epoch and add new clients State.modify $ \mls -> @@ -872,7 +882,7 @@ sendAndConsumeCommit mp = do mlsNewMembers = mempty } - pure events + pure resp 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 1f568245f3..7936d6b5cf 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 :| []) convId + API.Util.postQualifiedMembers userLHNotActivated (Qualified peer2 localdomain :| []) qconvId >>= 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 1a0fcebce7..6341179f8f 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1142,17 +1142,22 @@ listRemoteConvs remoteDomain uid = do pure $ filter (\qcnv -> qDomain qcnv == remoteDomain) allConvs postQualifiedMembers :: - (MonadReader TestSetup m, MonadHttp m) => + (MonadReader TestSetup m, MonadHttp m, HasGalley m) => UserId -> NonEmpty (Qualified UserId) -> - ConvId -> + Qualified ConvId -> m ResponseLBS postQualifiedMembers zusr invitees conv = do - g <- view tsUnversionedGalley + g <- viewGalley let invite = InviteQualified invitees roleNameWireAdmin post $ g - . paths ["v1", "conversations", toByteString' conv, "members", "v2"] + . paths + [ "conversations", + toByteString' . qDomain $ conv, + toByteString' . qUnqualified $ conv, + "members" + ] . zUser zusr . zConn "conn" . zType "access" @@ -2309,8 +2314,8 @@ assertMismatchQualified :: Client.QualifiedUserClients -> Client.QualifiedUserClients -> Assertions () -assertMismatchQualified failedToSend missing redundant deleted = do - assertExpected "failed to send" failedToSend (fmap mssFailedToSend . responseJsonMaybe) +assertMismatchQualified failureToSend missing redundant deleted = do + assertExpected "failed to send" failureToSend (fmap mssFailedToSend . responseJsonMaybe) assertExpected "missing" missing (fmap mssMissingClients . responseJsonMaybe) assertExpected "redundant" redundant (fmap mssRedundantClients . responseJsonMaybe) assertExpected "deleted" deleted (fmap mssDeletedClients . responseJsonMaybe)