Avoid MLS messages in sender client's event stream (#3379)

changelog.d/5-internal/dont-return-to-sender

@@ -0,0 +1 @@
+Avoid including MLS application messages in the sender client's event stream.

integration/test/Test/MLS.hs

@@ -11,6 +11,34 @@ import MLS.Util
 import SetupHelpers
 import Testlib.Prelude
 
+testSendMessageNoReturnToSender :: HasCallStack => App ()
+testSendMessageNoReturnToSender = do
+  [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain]
+  [alice1, alice2, bob1, bob2] <- traverse createMLSClient [alice, alice, bob, bob]
+  traverse_ uploadNewKeyPackage [alice2, bob1, bob2]
+  void $ createNewGroup alice1
+  void $ createAddCommit alice1 [alice, bob] >>= sendAndConsumeCommitBundle
+
+  -- alice1 sends a message to the conversation, all clients but alice1 receive
+  -- the message
+  withWebSockets [alice1, alice2, bob1, bob2] $ \(wsSender : wss) -> do
+    mp <- createApplicationMessage alice1 "hello, bob"
+    void . bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do
+      resp.status `shouldMatchInt` 201
+    for_ wss $ \ws -> do
+      n <- awaitMatch 3 (\n -> nPayload n %. "type" `isEqual` "conversation.mls-message-add") ws
+      nPayload n %. "data" `shouldMatch` T.decodeUtf8 (Base64.encode mp.message)
+    expectFailure (const $ pure ()) $
+      awaitMatch
+        3
+        ( \n ->
+            liftM2
+              (&&)
+              (nPayload n %. "type" `isEqual` "conversation.mls-message-add")
+              (nPayload n %. "data" `isEqual` T.decodeUtf8 (Base64.encode mp.message))
+        )
+        wsSender
+
 testMixedProtocolUpgrade :: HasCallStack => Domain -> App ()
 testMixedProtocolUpgrade secondDomain = do
   (alice, tid) <- createTeam OwnDomain

services/galley/src/Galley/API/MLS/Message.hs

@@ -232,7 +232,7 @@ postMLSCommitBundleToLocalConv qusr c conn bundle lConvOrSubId = do
 
   storeGroupInfo (tUnqualified lConvOrSub).id bundle.groupInfo
 
-  propagateMessage qusr lConvOrSub conn bundle.rawMessage (tUnqualified lConvOrSub).members
+  propagateMessage qusr (Just c) lConvOrSub conn bundle.rawMessage (tUnqualified lConvOrSub).members
     >>= mapM_ throwUnreachableUsers
 
   for_ bundle.welcome $ \welcome ->
@@ -375,7 +375,7 @@ postMLSMessageToLocalConv qusr c con msg convOrSubId = do
       when ((tUnqualified lConvOrSub).migrationState == MLSMigrationMixed) $
         throwS @'MLSUnsupportedMessage
 
-  unreachables <- propagateMessage qusr lConvOrSub con msg.rawMessage (tUnqualified lConvOrSub).members
+  unreachables <- propagateMessage qusr (Just c) lConvOrSub con msg.rawMessage (tUnqualified lConvOrSub).members
   pure ([], unreachables)
 
 postMLSMessageToRemoteConv ::

services/galley/src/Galley/API/MLS/Propagate.hs

@@ -43,13 +43,16 @@ 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,
@@ -58,12 +61,13 @@ propagateMessage ::
     Member TinyLog r
   ) =>
   Qualified UserId ->
+  Maybe ClientId ->
   Local ConvOrSubConv ->
   Maybe ConnId ->
   RawMLS Message ->
   ClientMap ->
   Sem r (Maybe UnreachableUsers)
-propagateMessage qusr lConvOrSub con msg cm = do
+propagateMessage qusr mSenderClient lConvOrSub con msg cm = do
   now <- input @UTCTime
   let mlsConv = (.conv) <$> lConvOrSub
       lmems = mcLocalMembers . tUnqualified $ mlsConv
@@ -102,21 +106,22 @@ propagateMessage qusr lConvOrSub con msg cm = do
             rmmMessage = Base64ByteString msg.raw
           }
   where
+    cmWithoutSender = maybe cm (flip cmRemoveClient cm . mkClientIdentity qusr) mSenderClient
     localMemberMLSClients :: Local x -> LocalMember -> [(UserId, ClientId)]
     localMemberMLSClients loc lm =
       let localUserQId = tUntagged (qualifyAs loc localUserId)
           localUserId = lmId lm
        in map
             (\(c, _) -> (localUserId, c))
-            (Map.assocs (Map.findWithDefault mempty localUserQId cm))
+            (Map.assocs (Map.findWithDefault mempty localUserQId cmWithoutSender))
 
     remoteMemberMLSClients :: RemoteMember -> [(UserId, ClientId)]
     remoteMemberMLSClients rm =
       let remoteUserQId = tUntagged (rmId rm)
           remoteUserId = qUnqualified remoteUserQId
        in map
             (\(c, _) -> (remoteUserId, c))
-            (Map.assocs (Map.findWithDefault mempty remoteUserQId cm))
+            (Map.assocs (Map.findWithDefault mempty remoteUserQId cmWithoutSender))
 
     remotesToQIds = fmap (tUntagged . rmId)
 

services/galley/src/Galley/API/MLS/Removal.hs

@@ -101,7 +101,7 @@ createAndSendRemoveProposals lConvOrSubConv indices qusr cm = do
           (publicMessageRef (cnvmlsCipherSuite meta) pmsg)
           ProposalOriginBackend
           proposal
-        propagateMessage qusr lConvOrSubConv Nothing msg cm
+        propagateMessage qusr Nothing lConvOrSubConv Nothing msg cm
 
 removeClientsWithClientMapRecursively ::
   ( Members

services/galley/test/integration/API/MLS.hs

@@ -967,9 +967,10 @@ testAppMessage = do
     mlsBracket clients $ \wss -> do
       (events, _) <- sendAndConsumeMessage message
       liftIO $ events @?= []
-      liftIO $
-        WS.assertMatchN_ (5 # WS.Second) wss $
+      liftIO $ do
+        WS.assertMatchN_ (5 # WS.Second) (tail wss) $
           wsAssertMLSMessage (fmap Conv qcnv) alice (mpMessage message)
+        WS.assertNoEvent (2 # WS.Second) [head wss]
 
 testAppMessage2 :: TestM ()
 testAppMessage2 = do
@@ -992,15 +993,16 @@ testAppMessage2 = do
 
     message <- createApplicationMessage bob1 "some text"
 
-    mlsBracket (alice1 : clients) $ \wss -> do
+    mlsBracket (alice1 : clients) $ \[wsAlice1, wsBob1, wsBob2, wsCharlie1] -> do
       (events, _) <- sendAndConsumeMessage message
       liftIO $ events @?= []
 
-      -- check that the corresponding event is received
-
-      liftIO $
-        WS.assertMatchN_ (5 # WS.Second) wss $
+      -- check that the corresponding event is received by everyone except bob1
+      -- (the sender) and no message is received by bob1
+      liftIO $ do
+        WS.assertMatchN_ (5 # WS.Second) [wsAlice1, wsBob2, wsCharlie1] $
           wsAssertMLSMessage (fmap Conv conversation) bob (mpMessage message)
+        WS.assertNoEvent (2 # WS.Second) [wsBob1]
 
 testAppMessageSomeReachable :: TestM ()
 testAppMessageSomeReachable = do
@@ -1829,7 +1831,7 @@ testBackendRemoveProposalLocalConvLocalClient = do
       WS.assertMatch_ (5 # WS.Second) wsB $
         wsAssertClientRemoved (ciClient bob1)
 
-      msg <- WS.assertMatch (5 # WS.Second) wsA $ \notification -> do
+      (msg : _) <- WS.assertMatchN (5 # WS.Second) [wsA, wsC] $ \notification -> do
         wsAssertBackendRemoveProposal bob (Conv <$> qcnv) idxBob1 notification
 
       for_ [alice1, bob2, charlie1] $
@@ -1838,8 +1840,9 @@ testBackendRemoveProposalLocalConvLocalClient = do
       mp <- createPendingProposalCommit charlie1
       events <- sendAndConsumeCommitBundle mp
       liftIO $ events @?= []
-      WS.assertMatchN_ (5 # WS.Second) [wsA, wsC] $ \n -> do
+      WS.assertMatchN_ (5 # WS.Second) [wsA] $ \n -> do
         wsAssertMLSMessage (Conv <$> qcnv) charlie (mpMessage mp) n
+      WS.assertNoEvent (2 # WS.Second) [wsC]
 
 testBackendRemoveProposalLocalConvRemoteClient :: TestM ()
 testBackendRemoveProposalLocalConvRemoteClient = do
@@ -2700,7 +2703,7 @@ testLeaveSubConv isSubConvCreator = do
     -- a member commits the pending proposal
     do
       leaveCommit <- createPendingProposalCommit (head others)
-      mlsBracket (firstLeaver : others) $ \(wsLeaver : wss) -> do
+      mlsBracket (firstLeaver : tail others) $ \(wsLeaver : wss) -> do
         events <-
           fst
             <$$> withTempMockFederator' ("on-mls-message-sent" ~> RemoteMLSMessageOk)
@@ -2713,7 +2716,7 @@ testLeaveSubConv isSubConvCreator = do
     -- send an application message
     do
       message <- createApplicationMessage (head others) "some text"
-      mlsBracket (firstLeaver : others) $ \(wsLeaver : wss) -> do
+      mlsBracket (firstLeaver : tail others) $ \(wsLeaver : wss) -> do
         (events, _) <- sendAndConsumeMessage message
         liftIO $ events @?= []
         WS.assertMatchN_ (5 # WS.Second) wss $ \n -> do