diff --git a/changelog.d/1-api-changes/mls-conv-add-across-federation b/changelog.d/1-api-changes/mls-conv-add-across-federation new file mode 100644 index 0000000000..6c86f1106b --- /dev/null +++ b/changelog.d/1-api-changes/mls-conv-add-across-federation @@ -0,0 +1 @@ +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 new file mode 100644 index 0000000000..22edab941a --- /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", "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 8a0422c5f2..b282a387dd 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] FailedToProcess 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..32a420f419 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 [] + mmssFailedToProcess = 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 + mmssFailedToProcess = failedToSend 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 + mmssFailedToProcess = failedToSend failed2 } -failed1 :: UnreachableUsers +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 = 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..50831a654f --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json @@ -0,0 +1,10 @@ +{ + "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 new file mode 100644 index 0000000000..a3a97ffbec --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json @@ -0,0 +1,14 @@ +{ + "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 new file mode 100644 index 0000000000..53ebbd357b --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json @@ -0,0 +1,20 @@ +{ + "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 1787ceab4b..89bda69ab4 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 + mmssFailedToProcess :: FailedToProcess } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema MLSMessageSendingStatus @@ -352,11 +338,7 @@ instance ToSchema MLSMessageSendingStatus where "time" (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 + <*> mmssFailedToProcess .= failedToProcessObjectSchema 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 dfe49a0595..4412315df3 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -78,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 @@ -97,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 @@ -290,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 -> @@ -421,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, @@ -476,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 -> @@ -563,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, @@ -578,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 @@ -602,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, @@ -616,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 @@ -632,11 +640,6 @@ 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 @@ -691,13 +694,13 @@ addMembersToLocalConversation lcnv users role = do 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 ) => - Bool -> Sing tag -> Qualified UserId -> Bool -> @@ -705,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 @@ -726,58 +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 <- if failEarly then errorIntolerant else 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 $ @@ -833,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, @@ -856,7 +870,6 @@ 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 11f24556ef..606206c674 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -25,6 +25,7 @@ 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 (..)) @@ -344,7 +345,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 <- @@ -354,34 +355,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 - False - 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 @@ -498,16 +513,17 @@ onUserDeleted origDomain udcn = do Public.RegularConv -> do let botsAndMembers = convBotsAndMembers conv removeUser (qualifyAs lc conv) (tUntagged deletedUser) - void $ - notifyConversationAction - False - (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 :: @@ -545,46 +561,46 @@ 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 @@ -830,3 +846,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..e744a7111a 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -27,7 +27,6 @@ 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 @@ -60,6 +59,7 @@ 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,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], FailedToProcess) 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], FailedToProcess) postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do let msg = rmValue (cbCommitMsg bundle) conv <- getLocalConvForUser qusr lcnv @@ -287,7 +286,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do senderClient <- fmap ciClient <$> getSenderIdentity qusr mc SMLSPlainText msg - events <- case msgPayload msg of + (events, failedToProcess) <- case msgPayload msg of CommitMessage commit -> do action <- getCommitData lconv mlsMeta (msgEpoch msg) commit @@ -298,7 +297,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do /= Set.fromList (map (snd . snd) (cmAssocs (paAdd action))) ) $ throwS @'MLSWelcomeMismatch - updates <- + (updates, failedToProcess) <- processCommitWithAction qusr senderClient @@ -311,7 +310,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do (msgSender msg) commit storeGroupInfoBundle lconv (cbGroupInfoBundle bundle) - pure updates + pure (updates, failedToProcess) ApplicationMessage _ -> throwS @'MLSUnsupportedMessage ProposalMessage _ -> throwS @'MLSUnsupportedMessage @@ -320,7 +319,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do for_ (cbWelcome bundle) $ postMLSWelcome lcnv conn - pure (events, unreachables) + pure (events, failedToProcess <> failedToSendMaybe unreachables) postMLSCommitBundleToRemoteConv :: ( Members MLSBundleStaticErrors r, @@ -339,7 +338,7 @@ postMLSCommitBundleToRemoteConv :: Maybe ConnId -> CommitBundle -> Remote ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], FailedToProcess) 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], FailedToProcess) 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], FailedToProcess) postMLSMessageToLocalConv qusr senderClient con smsg lcnv = case rmValue smsg of SomeMessage tag msg -> do @@ -483,13 +482,13 @@ postMLSMessageToLocalConv qusr senderClient con smsg lcnv = let lconv = qualifyAs lcnv conv -- validate message - events <- case tag of + (events, failedToProcess) <- 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 + processProposal qusr conv mlsMeta msg prop $> (mempty, mempty) SMLSCipherText -> case toMLSEnum' (msgContentType (msgPayload msg)) of Right CommitMessageTag -> throwS @'MLSUnsupportedMessage Right ProposalMessageTag -> throwS @'MLSUnsupportedMessage @@ -498,7 +497,7 @@ postMLSMessageToLocalConv qusr senderClient con smsg lcnv = -- forward message unreachables <- propagateMessage qusr lconv cm con (rmRaw smsg) - pure (events, unreachables) + pure (events, failedToProcess <> failedToSendMaybe unreachables) postMLSMessageToRemoteConv :: ( Members MLSMessageStaticErrors r, @@ -513,7 +512,7 @@ postMLSMessageToRemoteConv :: Maybe ConnId -> RawMLS SomeMessage -> Remote ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], FailedToProcess) postMLSMessageToRemoteConv loc qusr _senderClient con smsg rcnv = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr @@ -632,7 +631,7 @@ processCommit :: Epoch -> Sender 'MLSPlainText -> Commit -> - Sem r [LocalConversationUpdate] + Sem r ([LocalConversationUpdate], FailedToProcess) 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 @@ -767,11 +766,13 @@ processCommitWithAction :: ProposalAction -> Sender 'MLSPlainText -> Commit -> - Sem r [LocalConversationUpdate] + Sem r ([LocalConversationUpdate], FailedToProcess) 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) $> [] + NewMemberSender -> + processExternalCommit qusr senderClient lconv mlsMeta cm epoch action (cPath commit) + $> (mempty, mempty) _ -> throw (mlsProtocolError "Unexpected sender") processInternalCommit :: @@ -795,7 +796,7 @@ processInternalCommit :: ProposalAction -> KeyPackageRef -> Commit -> - Sem r [LocalConversationUpdate] + Sem r ([LocalConversationUpdate], FailedToProcess) processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action senderRef commit = do self <- noteS @'ConvNotFound $ getConvMember lconv (tUnqualified lconv) qusr @@ -1109,7 +1110,7 @@ executeProposalAction :: ConversationMLSData -> ClientMap -> ProposalAction -> - Sem r [LocalConversationUpdate] + Sem r ([LocalConversationUpdate], FailedToProcess) executeProposalAction qusr con lconv mlsMeta cm action = do let ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta) newUserClients = Map.assocs (paAdd action) @@ -1123,53 +1124,71 @@ 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. - removedUsers <- mapMaybe hush <$$> for (Map.assocs (paRemove action)) $ - \(qtarget, Set.map fst -> clients) -> runError @() $ do + (failedRemoveFetching, removedUsers) <- + fmap partitionEithers $ forM (Map.assocs (paRemove action)) $ \(qtarget, Set.map fst -> clients) -> do -- fetch clients from brig - 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) + 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) -- 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 - 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 + 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 membersToRemove <- catMaybes <$> for removedUsers (uncurry checkRemoval) -- add users to the conversation and send events - addEvents <- foldMap addMembers . nonEmpty . map fst $ newUserClients + 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 + ) -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do @@ -1183,8 +1202,17 @@ executeProposalAction qusr con lconv mlsMeta cm action = do for_ (Map.assocs (paRemove action)) $ \(qtarget, clients) -> do removeMLSClients (cnvmlsGroupId mlsMeta) qtarget (Set.map fst clients) - pure (addEvents <> removeEvents) + let failedToProcess = + failedToAdd (failedAddFetching <> failedAdding) + <> snd addEvents + <> failedToRemove failedRemoveFetching + <> snd removeEvents + pure (fst addEvents <> fst removeEvents, failedToProcess) where + onlyJoining :: Event -> [Qualified UserId] + onlyJoining (evtData -> EdMembersJoin ms) = smQualifiedId <$> mMembers ms + onlyJoining _ = [] + checkRemoval :: Qualified UserId -> Set ClientId -> @@ -1210,13 +1238,13 @@ executeProposalAction qusr con lconv mlsMeta cm action = do existingMembers :: Set (Qualified UserId) existingMembers = existingLocalMembers <> existingRemoteMembers - addMembers :: NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] + addMembers :: NonEmpty (Qualified UserId) -> Sem r ([LocalConversationUpdate], FailedToProcess) addMembers = -- FUTUREWORK: update key package ref mapping to reflect conversation membership foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap pure + . fmap (first pure) . updateLocalConversationUnchecked @'ConversationJoinTag lconv qusr con . flip ConversationJoin roleNameWireMember ) @@ -1224,12 +1252,12 @@ executeProposalAction qusr con lconv mlsMeta cm action = do . filter (flip Set.notMember existingMembers) . toList - removeMembers :: NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] + removeMembers :: NonEmpty (Qualified UserId) -> Sem r ([LocalConversationUpdate], FailedToProcess) removeMembers = foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap pure + . fmap (first pure) . updateLocalConversationUnchecked @'ConversationRemoveMembersTag lconv qusr con ) . nonEmpty @@ -1246,17 +1274,18 @@ getClientInfo :: Local x -> Qualified UserId -> SignatureSchemeTag -> - Sem r (Set ClientInfo) -getClientInfo loc = foldQualified loc getLocalMLSClients getRemoteMLSClients + Sem r (Either FederationError (Set ClientInfo)) +getClientInfo loc = + foldQualified loc (\lusr -> fmap Right . getLocalMLSClients lusr) getRemoteMLSClients getRemoteMLSClients :: ( Member FederatorAccess r ) => Remote UserId -> SignatureSchemeTag -> - Sem r (Set ClientInfo) + Sem r (Either FederationError (Set ClientInfo)) getRemoteMLSClients rusr ss = do - runFederated rusr $ + runFederatedEither 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 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 2460533ccb..85d685593b 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 $ + getUpdateResult . fmap (lcuEvent . fst) $ 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 $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationAccessDataTag (qualifyAs lusr cnv) (tUntagged lusr) @@ -331,7 +331,7 @@ updateConversationReceiptMode lusr zcon qcnv update = foldQualified lusr ( \lcnv -> - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ 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 -> pure convUpdate + ConversationUpdateResponseUpdate (convUpdate, _failedToProcess) -> 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 + lcuEvent . fst <$> updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv @@ -469,7 +469,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) @@ -675,6 +675,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, @@ -709,6 +710,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, @@ -734,6 +736,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, @@ -764,9 +767,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 - False (sing @'ConversationJoinTag) (tUntagged lusr) False @@ -808,7 +810,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 @@ -845,7 +847,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 @@ -950,6 +952,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, @@ -968,7 +971,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) $ @@ -976,6 +979,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, @@ -1036,6 +1040,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, @@ -1061,6 +1066,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, @@ -1102,7 +1108,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 @@ -1127,6 +1133,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, @@ -1148,12 +1155,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 @@ -1339,6 +1346,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, @@ -1360,6 +1368,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, @@ -1376,7 +1385,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 5689797051..62275b1d1f 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 :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) qconvId !!! 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 :| []) 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 @@ -2708,7 +2708,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 @@ -2734,6 +2734,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 @@ -2743,11 +2744,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 @@ -2964,10 +2965,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") @@ -2982,14 +2985,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 @@ -3002,7 +3004,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 @@ -3011,7 +3012,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 @@ -3348,7 +3349,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 @@ -3961,7 +3962,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 @@ -4237,7 +4238,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 f05cfe537e..4d897b0512 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 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 c6c1c2d3db..d1f8dbe9cf 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 @@ -38,6 +37,7 @@ 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,7 +49,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 +66,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 = @@ -111,6 +110,7 @@ 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,6 +663,61 @@ 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) @@ -1111,12 +1166,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 +1179,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 @?= failedToSend [charlie] testAppMessageUnreachable :: TestM () testAppMessageUnreachable = do @@ -1164,10 +1216,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 @?= failedToSend [bob] testRemoteToRemote :: TestM () testRemoteToRemote = do @@ -2038,7 +2090,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..2c14878c55 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,10 +840,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], UnreachableUsers) +sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], FailedToProcess) sendAndConsumeMessage mp = do res <- - fmap (mmssEvents Tuple.&&& mmssUnreachableUsers) $ + fmap (mmssEvents Tuple.&&& mmssFailedToProcess) $ responseJsonError =<< postMessage (mpSender mp) (mpMessage mp) 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], FailedToProcess) +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)