diff --git a/changelog.d/6-federation/wpb-4984-queueing b/changelog.d/6-federation/wpb-4984-queueing new file mode 100644 index 00000000000..c258c8eabda --- /dev/null +++ b/changelog.d/6-federation/wpb-4984-queueing @@ -0,0 +1 @@ +Remote MLS messages get queued via RabbitMQ diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index b525dc99739..d6bef3fc8a0 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -218,7 +218,7 @@ createGroup cid conv = do Nothing -> pure () resetGroup cid conv -createSubConv :: ClientIdentity -> String -> App () +createSubConv :: HasCallStack => ClientIdentity -> String -> App () createSubConv cid subId = do mls <- getMLSState sub <- getSubConversation cid mls.convId subId >>= getJSON 200 diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index b47355e4504..5a7cc4a9163 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -8,6 +8,7 @@ import Data.ByteString.Base64 qualified as Base64 import Data.ByteString.Char8 qualified as B8 import Data.Text.Encoding qualified as T import MLS.Util +import Notifications import SetupHelpers import Testlib.Prelude @@ -282,9 +283,11 @@ testMLSProtocolUpgrade secondDomain = do void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle void $ createExternalCommit bob1 Nothing >>= sendAndConsumeCommitBundle - -- charlie is added to the group - void $ uploadNewKeyPackage charlie1 - void $ createAddCommit alice1 [charlie] >>= sendAndConsumeCommitBundle + void $ withWebSocket bob $ \ws -> do + -- charlie is added to the group + void $ uploadNewKeyPackage charlie1 + void $ createAddCommit alice1 [charlie] >>= sendAndConsumeCommitBundle + awaitMatch 10 isNewMLSMessageNotif ws supportMLS alice bindResponse (putConversationProtocol bob conv "mls") $ \resp -> do @@ -300,8 +303,7 @@ testMLSProtocolUpgrade secondDomain = do bindResponse (putConversationProtocol bob conv "mls") $ \resp -> do resp.status `shouldMatchInt` 200 for_ wss $ \ws -> do - let isMessage n = nPayload n %. "type" `isEqual` "conversation.mls-message-add" - n <- awaitMatch 3 isMessage ws + n <- awaitMatch 3 isNewMLSMessageNotif ws msg <- asByteString (nPayload n %. "data") >>= showMessage alice1 let leafIndexCharlie = 2 msg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` leafIndexCharlie diff --git a/integration/test/Test/MLS/Message.hs b/integration/test/Test/MLS/Message.hs index 28f68bbfaba..88dce5a28d1 100644 --- a/integration/test/Test/MLS/Message.hs +++ b/integration/test/Test/MLS/Message.hs @@ -1,14 +1,42 @@ module Test.MLS.Message where -import API.Galley import MLS.Util import Notifications import SetupHelpers import Testlib.Prelude +-- | Test happy case of federated MLS message sending in both directions. +testApplicationMessage :: HasCallStack => App () +testApplicationMessage = do + -- local alice and alex, remote bob + [alice, alex, bob, betty] <- + createUsers + [OwnDomain, OwnDomain, OtherDomain, OtherDomain] + for_ [alex, bob, betty] $ \user -> connectTwoUsers alice user + + clients@[alice1, _alice2, alex1, _alex2, bob1, _bob2, _, _] <- + traverse + (createMLSClient def) + [alice, alice, alex, alex, bob, bob, betty, betty] + traverse_ uploadNewKeyPackage clients + void $ createNewGroup alice1 + + withWebSockets [alice, alex, bob, betty] $ \wss -> do + -- alice adds all other users (including her own client) + void $ createAddCommit alice1 [alice, alex, bob, betty] >>= sendAndConsumeCommitBundle + traverse_ (awaitMatch 10 isMemberJoinNotif) wss + + -- alex sends a message + void $ createApplicationMessage alex1 "hello" >>= sendAndConsumeMessage + traverse_ (awaitMatch 10 isNewMLSMessageNotif) wss + + -- bob sends a message + void $ createApplicationMessage bob1 "hey" >>= sendAndConsumeMessage + traverse_ (awaitMatch 10 isNewMLSMessageNotif) wss + testAppMessageSomeReachable :: HasCallStack => App () testAppMessageSomeReachable = do - (alice1, charlie) <- startDynamicBackends [mempty] $ \[thirdDomain] -> do + alice1 <- startDynamicBackends [mempty] $ \[thirdDomain] -> do ownDomain <- make OwnDomain & asString otherDomain <- make OtherDomain & asString [alice, bob, charlie] <- createAndConnectUsers [ownDomain, otherDomain, thirdDomain] @@ -19,11 +47,6 @@ testAppMessageSomeReachable = do void $ withWebSocket charlie $ \ws -> do void $ createAddCommit alice1 [bob, charlie] >>= sendAndConsumeCommitBundle awaitMatch 10 isMemberJoinNotif ws - pure (alice1, charlie) - - mp <- createApplicationMessage alice1 "hi, bob!" - bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do - resp.status `shouldMatchInt` 201 + pure alice1 - charlieId <- charlie %. "qualified_id" - resp.json %. "failed_to_send" `shouldMatchSet` [charlieId] + void $ createApplicationMessage alice1 "hi, bob!" >>= sendAndConsumeMessage diff --git a/integration/test/Test/MLS/SubConversation.hs b/integration/test/Test/MLS/SubConversation.hs index 24ec1c354c0..ed5aa95c3d4 100644 --- a/integration/test/Test/MLS/SubConversation.hs +++ b/integration/test/Test/MLS/SubConversation.hs @@ -38,10 +38,10 @@ testDeleteParentOfSubConv secondDomain = do (_, qcnv) <- createNewGroup alice1 withWebSocket bob $ \ws -> do void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle - void $ awaitMatch 3 isMemberJoinNotif ws + void $ awaitMatch 10 isMemberJoinNotif ws + -- bob creates a subconversation and adds his own client createSubConv bob1 "conference" - -- bob adds his client to the subconversation void $ createPendingProposalCommit bob1 >>= sendAndConsumeCommitBundle -- alice joins with her own client 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 b230278e198..27fba120068 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,30 +24,26 @@ import Data.Qualified import Data.UUID qualified 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"), - mmssFailedToSendTo = mempty + mmssTime = toUTCTimeMillis (read "1864-04-12 12:22:43.673 UTC") } testObject_MLSMessageSendingStatus2 :: MLSMessageSendingStatus testObject_MLSMessageSendingStatus2 = MLSMessageSendingStatus { mmssEvents = [], - mmssTime = toUTCTimeMillis (read "2001-04-12 12:22:43.673 UTC"), - mmssFailedToSendTo = unreachableFromList failed1 + mmssTime = toUTCTimeMillis (read "2001-04-12 12:22:43.673 UTC") } testObject_MLSMessageSendingStatus3 :: MLSMessageSendingStatus testObject_MLSMessageSendingStatus3 = MLSMessageSendingStatus { mmssEvents = [], - mmssTime = toUTCTimeMillis (read "1999-04-12 12:22:43.673 UTC"), - mmssFailedToSendTo = unreachableFromList failed2 + mmssTime = toUTCTimeMillis (read "1999-04-12 12:22:43.673 UTC") } failed1 :: [Qualified UserId] diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus2.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus2.json index fb932f00593..5d03a97ba11 100644 --- a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus2.json +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus2.json @@ -1,10 +1,4 @@ { "events": [], - "time": "2001-04-12T12:22:43.673Z", - "failed_to_send": [ - { - "domain": "offline.example.com", - "id": "00000000-0000-0000-0000-000200000008" - } - ] + "time": "2001-04-12T12:22:43.673Z" } diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus3.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus3.json index 87c92624480..47e408103f9 100644 --- a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus3.json +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus3.json @@ -1,14 +1,4 @@ { "events": [], - "time": "1999-04-12T12:22:43.673Z", - "failed_to_send": [ - { - "domain": "golden.example.com", - "id": "00000000-0000-0000-0000-000200000008" - }, - { - "domain": "golden.example.com", - "id": "00000000-0000-0000-0000-000100000007" - } - ] + "time": "1999-04-12T12:22:43.673Z" } diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index d9e6aa1f624..c13dcc0d96f 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -59,7 +59,6 @@ import Wire.API.MLS.Proposal import Wire.API.MLS.ProtocolVersion import Wire.API.MLS.Serialisation import Wire.API.MLS.Welcome -import Wire.API.Unreachable import Wire.Arbitrary data WireFormatTag @@ -377,11 +376,7 @@ verifyMessageSignature ctx msgContent authData pubkey = isJust $ do data MLSMessageSendingStatus = MLSMessageSendingStatus { mmssEvents :: [Event], - mmssTime :: UTCTimeMillis, - -- | An optional list of unreachable users an application message could not - -- be sent to. In case of commits and unreachable users use the - -- MLSMessageResponseUnreachableBackends data constructor. - mmssFailedToSendTo :: Maybe UnreachableUsers + mmssTime :: UTCTimeMillis } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema MLSMessageSendingStatus @@ -400,10 +395,3 @@ instance ToSchema MLSMessageSendingStatus where "time" (description ?~ "The time of sending the message.") schema - <*> mmssFailedToSendTo - .= maybe_ - ( optFieldWithDocModifier - "failed_to_send" - (description ?~ "List of federated users who could not be reached and did not receive the message") - schema - ) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index f3fc8fa62d1..cced908c9f6 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -120,9 +120,9 @@ federationSitemap = :<|> Named @"get-one2one-conversation" getOne2OneConversation onClientRemoved :: - ( Member ConversationStore r, + ( Member BackendNotificationQueueAccess r, + Member ConversationStore r, Member ExternalAccess r, - Member FederatorAccess r, Member GundeckAccess r, Member (Input Env) r, Member (Input (Local ())) r, @@ -374,7 +374,6 @@ sendMessage originDomain msr = do onUserDeleted :: ( Member BackendNotificationQueueAccess r, Member ConversationStore r, - Member FederatorAccess r, Member FireAndForget r, Member ExternalAccess r, Member GundeckAccess r, @@ -627,7 +626,7 @@ sendMLSMessage remoteDomain msr = handleMLSMessageErrors $ do msg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage raw (ctype, qConvOrSub) <- getConvFromGroupId msg.groupId when (qUnqualified qConvOrSub /= msr.convOrSubId) $ throwS @'MLSGroupConversationMismatch - MLSMessageResponseUpdates . map lcuUpdate . fst + MLSMessageResponseUpdates . map lcuUpdate <$> postMLSMessage loc (tUntagged sender) @@ -660,11 +659,8 @@ getSubConversationForRemoteUser domain GetSubConversationsRequest {..} = leaveSubConversation :: ( HasLeaveSubConversationEffects r, - Members - '[ Input (Local ()), - Resource - ] - r + Member (Input (Local ())) r, + Member Resource r ) => Domain -> LeaveSubConversationRequest -> diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index ad7ace09d5a..6e25da04853 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -81,7 +81,6 @@ import Wire.API.MLS.GroupInfo import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation -import Wire.API.Unreachable -- FUTUREWORK -- - Check that the capabilities of a leaf node in an add proposal contains all @@ -140,11 +139,11 @@ postMLSMessageFromLocalUser lusr c conn smsg = do assertMLSEnabled imsg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage smsg (ctype, cnvOrSub) <- getConvFromGroupId imsg.groupId - (events, unreachables) <- - first (map lcuEvent) + events <- + map lcuEvent <$> postMLSMessage lusr (tUntagged lusr) c ctype cnvOrSub (Just conn) imsg t <- toUTCTimeMillis <$> input - pure $ MLSMessageSendingStatus events t unreachables + pure $ MLSMessageSendingStatus events t postMLSCommitBundle :: ( HasProposalEffects r, @@ -188,7 +187,7 @@ postMLSCommitBundleFromLocalUser lusr c conn bundle = do map lcuEvent <$> postMLSCommitBundle lusr (tUntagged lusr) c ctype qConvOrSub (Just conn) ibundle t <- toUTCTimeMillis <$> input - pure $ MLSMessageSendingStatus events t mempty + pure $ MLSMessageSendingStatus events t postMLSCommitBundleToLocalConv :: ( HasProposalEffects r, @@ -259,7 +258,6 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do storeGroupInfo (tUnqualified lConvOrSub).id (GroupInfoData bundle.groupInfo.raw) propagateMessage qusr (Just c) lConvOrSub conn bundle.rawMessage (tUnqualified lConvOrSub).members - >>= mapM_ (throw . unreachableUsersToUnreachableBackends) for_ bundle.welcome $ \welcome -> sendWelcomes lConvOrSubId qusr conn newClients welcome @@ -342,7 +340,7 @@ postMLSMessage :: Qualified ConvOrSubConvId -> Maybe ConnId -> IncomingMessage -> - Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) + Sem r [LocalConversationUpdate] postMLSMessage loc qusr c ctype qconvOrSub con msg = do foldQualified loc @@ -383,7 +381,7 @@ postMLSMessageToLocalConv :: IncomingMessage -> ConvType -> Local ConvOrSubConvId -> - Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) + Sem r [LocalConversationUpdate] postMLSMessageToLocalConv qusr c con msg ctype convOrSubId = do lConvOrSub <- fetchConvOrSub qusr msg.groupId ctype convOrSubId let convOrSub = tUnqualified lConvOrSub @@ -413,8 +411,8 @@ postMLSMessageToLocalConv qusr c con msg ctype convOrSubId = do (epochInt msg.epoch < epochInt convOrSub.mlsMeta.cnvmlsEpoch - 2) $ throwS @'MLSStaleMessage - unreachables <- propagateMessage qusr (Just c) lConvOrSub con msg.rawMessage (tUnqualified lConvOrSub).members - pure ([], unreachables) + propagateMessage qusr (Just c) lConvOrSub con msg.rawMessage (tUnqualified lConvOrSub).members + pure [] postMLSMessageToRemoteConv :: ( Members MLSMessageStaticErrors r, @@ -427,7 +425,7 @@ postMLSMessageToRemoteConv :: Maybe ConnId -> IncomingMessage -> Remote ConvOrSubConvId -> - Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) + Sem r [LocalConversationUpdate] postMLSMessageToRemoteConv loc qusr senderClient con msg rConvOrSubId = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr @@ -455,11 +453,10 @@ postMLSMessageToRemoteConv loc qusr senderClient con msg rConvOrSubId = do \sent to. The remote end returned: " <> LT.pack (intercalate ", " (show <$> Set.toList (Set.map domainText ds))) MLSMessageResponseUpdates updates -> do - lcus <- fmap fst . runOutputList $ + fmap fst . runOutputList $ for_ updates $ \update -> do me <- updateLocalStateOfRemoteConv (qualifyAs rConvOrSubId update) con for_ me $ \e -> output (LocalConversationUpdate e update) - pure (lcus, Nothing) MLSMessageResponseNonFederatingBackends e -> throw e storeGroupInfo :: diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 340d91fc4d0..da90671702c 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -18,8 +18,6 @@ module Galley.API.MLS.Propagate where import Control.Comonad -import Data.Aeson qualified as A -import Data.Domain import Data.Id import Data.Json.Util import Data.Map qualified as Map @@ -27,34 +25,31 @@ import Data.Qualified import Data.Time import Galley.API.MLS.Types import Galley.API.Push +import Galley.API.Util import Galley.Data.Services import Galley.Effects -import Galley.Effects.FederatorAccess +import Galley.Effects.BackendNotificationQueueAccess import Galley.Types.Conversations.Members import Imports -import Network.Wai.Utilities.JSONResponse +import Network.AMQP qualified as Q import Polysemy import Polysemy.Input import Polysemy.TinyLog hiding (trace) -import System.Logger.Class qualified as Logger -import Wire.API.Error 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.Credential import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.Message -import Wire.API.Unreachable -- | Propagate a message. -- The message will not be propagated to the sender client if provided. This is -- a requirement from Core Crypto and the clients. propagateMessage :: - ( Member ExternalAccess r, - Member FederatorAccess r, + ( Member BackendNotificationQueueAccess r, + Member ExternalAccess r, Member GundeckAccess r, Member (Input UTCTime) r, Member TinyLog r @@ -65,7 +60,7 @@ propagateMessage :: Maybe ConnId -> RawMLS Message -> ClientMap -> - Sem r (Maybe UnreachableUsers) + Sem r () propagateMessage qusr mSenderClient lConvOrSub con msg cm = do now <- input @UTCTime let mlsConv = (.conv) <$> lConvOrSub @@ -88,18 +83,16 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do newMessagePush botMap con mm (lmems >>= localMemberMLSClients mlsConv) e -- send to remotes - unreachableFromList . concat - <$$> traverse handleError - <=< runFederatedConcurrentlyEither (map remoteMemberQualify rmems) - $ \(tUnqualified -> rs) -> - fedClient @'Galley @"on-mls-message-sent" $ + (either (logRemoteNotificationError @"on-mls-message-sent") (const (pure ())) <=< enqueueNotificationsConcurrently Q.Persistent (map remoteMemberQualify rmems)) $ + \rs -> + fedQueueClient @'Galley @"on-mls-message-sent" $ RemoteMLSMessage { time = now, sender = qusr, metadata = mm, conversation = qUnqualified qcnv, subConversation = sconv, - recipients = rs >>= remoteMemberMLSClients, + recipients = tUnqualified rs >>= remoteMemberMLSClients, message = Base64ByteString msg.raw } where @@ -119,20 +112,3 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do in map (\(c, _) -> (remoteUserId, c)) (Map.assocs (Map.findWithDefault mempty remoteUserQId cmWithoutSender)) - - remotesToQIds = fmap (tUntagged . rmId) - - handleError :: - Member TinyLog r => - Either (Remote [RemoteMember], FederationError) (Remote x) -> - Sem r [Qualified UserId] - handleError (Right _) = pure [] - handleError (Left (r, e)) = do - logFedError r (toResponse e) - pure $ remotesToQIds (tUnqualified r) - logFedError :: Member TinyLog r => Remote x -> JSONResponse -> Sem r () - logFedError r e = - warn $ - Logger.msg ("A message could not be delivered to a remote backend" :: ByteString) - . Logger.field "remote_domain" (domainText (tDomain r)) - . Logger.field "error" (A.encode e.value) diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/services/galley/src/Galley/API/MLS/Removal.hs index 31725dd731f..3a796a75c22 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/services/galley/src/Galley/API/MLS/Removal.hs @@ -59,8 +59,8 @@ import Wire.API.MLS.SubConversation createAndSendRemoveProposals :: ( Member (Input UTCTime) r, Member TinyLog r, + Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member FederatorAccess r, Member GundeckAccess r, Member ProposalStore r, Member (Input Env) r, @@ -104,18 +104,15 @@ createAndSendRemoveProposals lConvOrSubConv indices qusr cm = do propagateMessage qusr Nothing lConvOrSubConv Nothing msg cm removeClientsWithClientMapRecursively :: - ( Members - '[ Input UTCTime, - TinyLog, - ExternalAccess, - FederatorAccess, - GundeckAccess, - MemberStore, - ProposalStore, - SubConversationStore, - Input Env - ] - r, + ( Member (Input UTCTime) r, + Member TinyLog r, + Member BackendNotificationQueueAccess r, + Member ExternalAccess r, + Member GundeckAccess r, + Member MemberStore r, + Member ProposalStore r, + Member SubConversationStore r, + Member (Input Env) r, Functor f, Foldable f ) => @@ -152,8 +149,8 @@ removeClientsWithClientMapRecursively lMlsConv getClients qusr = do -- | Send remove proposals for a single client of a user to the local conversation. removeClient :: - ( Member ExternalAccess r, - Member FederatorAccess r, + ( Member BackendNotificationQueueAccess r, + Member ExternalAccess r, Member GundeckAccess r, Member (Input Env) r, Member (Input UTCTime) r, @@ -175,8 +172,8 @@ removeClient lc qusr c = do -- | Send remove proposals for all clients of the user to the local conversation. removeUser :: - ( Member ExternalAccess r, - Member FederatorAccess r, + ( Member BackendNotificationQueueAccess r, + Member ExternalAccess r, Member GundeckAccess r, Member (Input Env) r, Member (Input UTCTime) r, @@ -212,8 +209,8 @@ listSubConversations' cid = do -- | Send remove proposals for clients of users that are not part of a conversation removeExtraneousClients :: - ( Member ExternalAccess r, - Member FederatorAccess r, + ( Member BackendNotificationQueueAccess r, + Member ExternalAccess r, Member GundeckAccess r, Member (Input Env) r, Member (Input UTCTime) r, diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs index cb849571ca6..9b5ed34274d 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -56,7 +56,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.Resource import Polysemy.TinyLog -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Galley @@ -325,7 +325,8 @@ deleteRemoteSubConversation lusr rcnvId scnvId dsc = do type HasLeaveSubConversationEffects r = ( Members - '[ ConversationStore, + '[ BackendNotificationQueueAccess, + ConversationStore, ExternalAccess, FederatorAccess, GundeckAccess, @@ -348,14 +349,11 @@ type LeaveSubConversationStaticErrors = leaveSubConversation :: ( HasLeaveSubConversationEffects r, - Members - '[ Error MLSProtocolError, - Error FederationError, - ErrorS 'MLSStaleMessage, - ErrorS 'MLSNotEnabled, - Resource - ] - r, + Member (Error MLSProtocolError) r, + Member (Error FederationError) r, + Member (ErrorS 'MLSStaleMessage) r, + Member (ErrorS 'MLSNotEnabled) r, + Member Resource r, Members LeaveSubConversationStaticErrors r ) => Local UserId -> @@ -375,14 +373,10 @@ leaveSubConversation lusr cli qcnv sub = leaveLocalSubConversation :: ( HasLeaveSubConversationEffects r, - Members - '[ Error MLSProtocolError, - ErrorS 'MLSStaleMessage, - ErrorS 'MLSNotEnabled, - Resource, - MemberStore - ] - r, + Member (Error MLSProtocolError) r, + Member (ErrorS 'MLSStaleMessage) r, + Member (ErrorS 'MLSNotEnabled) r, + Member Resource r, Members LeaveSubConversationStaticErrors r ) => ClientIdentity -> diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 7fd56d2c497..6bb5d767a76 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -64,7 +64,6 @@ import Wire.API.MLS.SubConversation import Wire.API.Message import Wire.API.Routes.MultiTablePaging import Wire.API.Routes.Version -import Wire.API.Unreachable tests :: IO TestSetup -> TestTree tests s = @@ -109,7 +108,6 @@ tests s = [ testGroup "Local Sender/Local Conversation" [ test s "send application message" testAppMessage, - test s "send remote application message" testRemoteAppMessage, test s "another participant sends an application message" testAppMessage2, test s "send message, remote users are unreachable" testAppMessageUnreachable ], @@ -123,11 +121,7 @@ tests s = [ test s "POST /federation/send-mls-message" testRemoteToLocal, test s "POST /federation/send-mls-message, remote user is not a conversation member" testRemoteNonMemberToLocal, test s "POST /federation/send-mls-message, remote user sends to wrong conversation" testRemoteToLocalWrongConversation - ], - testGroup - "Remote Sender/Remote Conversation" - [ test s "POST /federation/on-mls-message-sent" testRemoteToRemote - ] -- all is mocked + ] ], testGroup "Proposal" @@ -566,36 +560,6 @@ testUnknownProposalRefCommit = do messageSentMock <|> welcomeMock - - ((message, events), reqs) <- withTempMockFederator' mock $ do - void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle - message <- createApplicationMessage alice1 "hello" - (events, _) <- sendAndConsumeMessage message - pure (message, events) - - liftIO $ do - req <- assertOne $ filter ((== "on-mls-message-sent") . frRPC) reqs - frTargetDomain req @?= qDomain bob - bdy :: RemoteMLSMessage <- case Aeson.eitherDecode (frBody req) of - Right b -> pure b - Left e -> assertFailure $ "Could not parse on-mls-message-sent request body: " <> e - bdy.sender @?= alice - bdy.conversation @?= qUnqualified qcnv - bdy.recipients @?= [(ciUser bob1, ciClient bob1)] - bdy.message @?= Base64ByteString (mpMessage message) - - liftIO $ assertBool "Unexpected events returned" (null events) - -- The following test happens within backend B -- Alice@A is remote and Bob@B is local -- Alice creates a remote conversation and invites Bob @@ -833,7 +797,7 @@ testAppMessage = do message <- createApplicationMessage alice1 "some text" mlsBracket clients $ \wss -> do - (events, _) <- sendAndConsumeMessage message + events <- sendAndConsumeMessage message liftIO $ events @?= [] liftIO $ do WS.assertMatchN_ (5 # WS.Second) (tail wss) $ @@ -862,7 +826,7 @@ testAppMessage2 = do message <- createApplicationMessage bob1 "some text" mlsBracket (alice1 : clients) $ \[wsAlice1, wsBob1, wsBob2, wsCharlie1] -> do - (events, _) <- sendAndConsumeMessage message + events <- sendAndConsumeMessage message liftIO $ events @?= [] -- check that the corresponding event is received by everyone except bob1 @@ -889,65 +853,9 @@ testAppMessageUnreachable = do sendAndConsumeCommitBundle commit message <- createApplicationMessage alice1 "hi, bob!" - (_, failed) <- sendAndConsumeMessage message + _ <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - failed @?= unreachableFromList [bob] - -testRemoteToRemote :: TestM () -testRemoteToRemote = do - localDomain <- viewFederationDomain - c <- view tsCannon - alice <- randomUser - eve <- randomUser - bob <- randomId - conv <- randomId - let aliceC1 = newClientId 0 - aliceC2 = newClientId 1 - eveC = newClientId 0 - bdom = Domain "bob.example.com" - qconv = Qualified conv bdom - qbob = Qualified bob bdom - qalice = Qualified alice localDomain - now <- liftIO getCurrentTime - fedGalleyClient <- view tsFedGalleyClient - - -- only add alice to the remote conversation - connectWithRemoteUser alice qbob - let cu = - ConversationUpdate - { cuTime = now, - cuOrigUserId = qbob, - cuConvId = conv, - cuAlreadyPresentUsers = [], - cuAction = - SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) - } - void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu - - let txt = "Hello from another backend" - rcpts = [(alice, aliceC1), (alice, aliceC2), (eve, eveC)] - rm = - RemoteMLSMessage - { time = now, - metadata = defMessageMetadata, - sender = qbob, - conversation = conv, - subConversation = Nothing, - recipients = rcpts, - message = Base64ByteString txt - } - - -- send message to alice and check reception - WS.bracketAsClientRN c [(alice, aliceC1), (alice, aliceC2), (eve, eveC)] $ \[wsA1, wsA2, wsE] -> do - void $ runFedClient @"on-mls-message-sent" fedGalleyClient bdom rm - liftIO $ do - -- alice should receive the message on her first client - WS.assertMatch_ (5 # Second) wsA1 $ \n -> wsAssertMLSMessage (fmap Conv qconv) qbob txt n - WS.assertMatch_ (5 # Second) wsA2 $ \n -> wsAssertMLSMessage (fmap Conv qconv) qbob txt n - - -- eve should not receive the message - WS.assertNoEvent (1 # Second) [wsE] testRemoteToRemoteInSub :: TestM () testRemoteToRemoteInSub = do @@ -2068,7 +1976,7 @@ testSendMessageSubConv = do message <- createApplicationMessage alice1 "some text" mlsBracket [bob1, bob2] $ \wss -> do - (events, _) <- sendAndConsumeMessage message + events <- sendAndConsumeMessage message liftIO $ events @?= [] liftIO $ WS.assertMatchN_ (5 # WS.Second) wss $ \n -> do diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 97ddd4fc1de..435c4f0c6a8 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -50,7 +50,6 @@ import Data.Set qualified as Set import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Time -import Data.Tuple.Extra qualified as Tuple import Data.UUID qualified as UUID import Data.UUID.V4 qualified as UUIDV4 import Galley.Keys @@ -83,7 +82,6 @@ import Wire.API.MLS.LeafNode import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation -import Wire.API.Unreachable import Wire.API.User.Client import Wire.API.User.Client.Prekey @@ -866,11 +864,11 @@ consumeMessage1 cid msg = -- | Send an MLS message and simulate clients receiving it. If the message is a -- commit, the 'sendAndConsumeCommitBundle' function should be used instead. -sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], Maybe UnreachableUsers) +sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest [Event] sendAndConsumeMessage mp = do for_ mp.mpWelcome $ \_ -> liftIO $ assertFailure "use sendAndConsumeCommitBundle" res <- - fmap (mmssEvents Tuple.&&& mmssFailedToSendTo) $ + fmap mmssEvents $ responseJsonError =<< postMessage (mpSender mp) (mpMessage mp)