MLS: send ext commit before sending ext proposals (#4412)

* MLS: send ext commit before sending ext proposals

* add changelog and streamline test

Author: stefanwire

changelog.d/3-bug-fixes/WPB-15400

@@ -0,0 +1,3 @@
+MLS: when recreating external (backend) proposals, these are now propagated to
+the clients only after the corresponding external commit has been forwarded to
+the clients.

integration/test/Test/MLS/SubConversation.hs

@@ -338,12 +338,38 @@ testResendingProposals = do
   leaveConv subConvId bob2
   leaveConv subConvId bob3
 
-  subConv <- getMLSConv subConvId
-  withWebSockets (charlie1 : toList subConv.members) \wss -> do
-    void $ createExternalCommit subConvId charlie1 Nothing >>= sendAndConsumeCommitBundle
+  withWebSockets [alice1, alice2, charlie1] \[wsAlice1, wsAlice2, wsCharlie1] -> do
+    void
+      $ createExternalCommit subConvId charlie1 Nothing
+      >>= postMLSCommitBundle charlie1
+      . mkBundle
+      >>= getJSON 201
+
+    -- increment epoch and add charlie1
+    modifyMLSState $ \mls ->
+      mls
+        { convs =
+            Map.adjust
+              ( \conv' ->
+                  conv'
+                    { epoch = conv'.epoch + 1,
+                      members = conv'.members <> conv'.newMembers,
+                      newMembers = mempty
+                    }
+              )
+              subConvId
+              mls.convs
+        }
 
     -- consume proposals after backend resends them
-    for_ wss \ws -> do
+    for_ [wsAlice1, wsAlice2] $ \ws -> do
+      commitMsg <- consumeMessage subConvId def (fromJust ws.client) Nothing ws
+      commitMsg %. "message.content.sender" `shouldMatch` "NewMemberCommit"
+      replicateM 3 do
+        msg <- consumeMessage subConvId def (fromJust ws.client) Nothing ws
+        msg %. "message.content.sender.External" `shouldMatchInt` 0
+    void $ do
+      let ws = wsCharlie1
       replicateM 3 do
         msg <- consumeMessage subConvId def (fromJust ws.client) Nothing ws
         msg %. "message.content.sender.External" `shouldMatchInt` 0

services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs

@@ -23,6 +23,7 @@ where
 
 import Control.Comonad
 import Control.Lens (forOf_)
+import Control.Monad.Codensity
 import Data.Map qualified as Map
 import Data.Qualified
 import Data.Set qualified as Set
@@ -141,52 +142,56 @@ processExternalCommit ::
   Epoch ->
   ExternalCommitAction ->
   Maybe UpdatePath ->
-  Sem r ()
+  Codensity (Sem r) ()
 processExternalCommit senderIdentity lConvOrSub ciphersuite ciphersuiteUpdate epoch action updatePath = do
   let convOrSub = tUnqualified lConvOrSub
 
   -- only members can join a subconversation
   forOf_ _SubConv convOrSub $ \(mlsConv, _) ->
     unless (isClientMember senderIdentity (mcMembers mlsConv)) $
-      throwS @'MLSSubConvClientNotInParent
+      lift $
+        throwS @'MLSSubConvClientNotInParent
 
   -- extract leaf node from update path and validate it
   leafNode <-
     (.leaf)
-      <$> note
-        (mlsProtocolError "External commits need an update path")
-        updatePath
+      <$> lift
+        ( note
+            (mlsProtocolError "External commits need an update path")
+            updatePath
+        )
   let groupId = cnvmlsGroupId convOrSub.mlsMeta
   let extra = LeafNodeTBSExtraCommit groupId action.add
   case validateLeafNode ciphersuite (Just senderIdentity) extra leafNode.value of
     Left errMsg ->
-      throw $
+      lift . throw $
         mlsProtocolError ("Tried to add invalid LeafNode: " <> errMsg)
     Right _ -> pure ()
 
-  withCommitLock (fmap (.id) lConvOrSub) groupId epoch $ do
-    executeExternalCommitAction lConvOrSub senderIdentity action
+  withCommitLock (fmap (.id) lConvOrSub) groupId epoch
 
-    -- increment epoch number
-    lConvOrSub' <- for lConvOrSub incrementEpoch
+  lift $ executeExternalCommitAction lConvOrSub senderIdentity action
 
-    -- fetch backend remove proposals of the previous epoch
-    indices0 <- getPendingBackendRemoveProposals groupId epoch
+  -- increment epoch number
+  lConvOrSub' <- for lConvOrSub $ lift . incrementEpoch
 
-    -- skip proposals for clients already removed by the external commit
-    let indices = maybe id Set.delete action.remove indices0
+  -- fetch backend remove proposals of the previous epoch
+  indices0 <- lift $ getPendingBackendRemoveProposals groupId epoch
 
-    -- set cipher suite
-    when ciphersuiteUpdate $ case convOrSub.id of
-      Conv cid -> setConversationCipherSuite cid ciphersuite
-      SubConv cid sub -> setSubConversationCipherSuite cid sub ciphersuite
+  -- skip proposals for clients already removed by the external commit
+  let indices = maybe id Set.delete action.remove indices0
 
-    -- requeue backend remove proposals for the current epoch
-    createAndSendRemoveProposals
-      lConvOrSub'
-      indices
-      (cidQualifiedUser senderIdentity)
-      (tUnqualified lConvOrSub').members
+  -- set cipher suite
+  lift $ when ciphersuiteUpdate $ case convOrSub.id of
+    Conv cid -> setConversationCipherSuite cid ciphersuite
+    SubConv cid sub -> setSubConversationCipherSuite cid sub ciphersuite
+
+  -- requeue backend remove proposals for the current epoch
+  createAndSendRemoveProposals
+    lConvOrSub'
+    (toList indices)
+    (cidQualifiedUser senderIdentity)
+    (tUnqualified lConvOrSub').members
 
 executeExternalCommitAction ::
   forall r.