integration: Wait for the right notification when consuming commit bu…

…ndles
wireapp · Oct 28, 2024 · 5e1b64c · 5e1b64c
1 parent e65ea5f
commit 5e1b64c
Show file tree

Hide file tree

Showing 4 changed files with 101 additions and 85 deletions.
diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs
@@ -185,6 +185,8 @@ generateKeyPackage cid suite = do
 -- | Create conversation and corresponding group.
 --
 -- returns (groupId, convId)
+--
+-- TODO: Don't return groupId as it is already part of ConvId or remove it from ConvID.
 createNewGroup :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App (String, ConvId)
 createNewGroup cs cid = do
   conv <- postConversation cid defMLS >>= getJSON 201
@@ -603,7 +605,7 @@ consumingMessages mp = Codensity $ \k -> do
     -- at this point we know that every new user has been added to the
     -- conversation
     for_ (zip clients wss) $ \((cid, t), ws) -> case t of
-      MLSNotificationMessageTag -> void $ consumeMessageNoExternal conv.ciphersuite cid (Just mp) ws
+      MLSNotificationMessageTag -> void $ consumeMessageNoExternal conv.ciphersuite cid mp ws
       MLSNotificationWelcomeTag -> consumeWelcome cid mp ws
     pure r
 
@@ -628,15 +630,15 @@ consumeMessage :: (HasCallStack) => Ciphersuite -> ClientIdentity -> Maybe Messa
 consumeMessage = consumeMessageWithPredicate isNewMLSMessageNotif
 
 -- | like 'consumeMessage' but will not consume a message where the sender is the backend
-consumeMessageNoExternal :: (HasCallStack) => Ciphersuite -> ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value
-consumeMessageNoExternal cs cid = consumeMessageWithPredicate isNewMLSMessageNotifButNoProposal cs cid
+consumeMessageNoExternal :: (HasCallStack) => Ciphersuite -> ClientIdentity -> MessagePackage -> WebSocket -> App Value
+consumeMessageNoExternal cs cid mp = consumeMessageWithPredicate isNewMLSMessageNotifButNoProposal cs cid (Just mp)
   where
     -- the backend (correctly) reacts to a commit removing someone from a parent conversation with a
     -- remove proposal, however, we don't want to consume this here
     isNewMLSMessageNotifButNoProposal :: Value -> App Bool
     isNewMLSMessageNotifButNoProposal n = do
-      isNotif <- isNewMLSMessageNotif n
-      if isNotif
+      isRelevantNotif <- isNewMLSMessageNotif n &&~ isNotifConvId mp.convId n
+      if isRelevantNotif
         then do
           msg <- n %. "payload.0.data" & asByteString >>= showMessage cs cid
           sender <- msg `lookupField` "message.content.sender" `catch` \(_ :: AssertionFailure) -> pure Nothing

diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs
@@ -127,6 +127,11 @@ isConvLeaveNotifWithLeaver user n =
 isNotifConv :: (MakesValue conv, MakesValue a, HasCallStack) => conv -> a -> App Bool
 isNotifConv conv n = fieldEquals n "payload.0.qualified_conversation" (objQidObject conv)
 
+isNotifConvId :: (MakesValue a, HasCallStack) => ConvId -> a -> App Bool
+isNotifConvId conv n =
+  fieldEquals n "payload.0.qualified_conversation" (objQidObject conv)
+    &&~ fieldEquals n "payload.0.subconv" conv.subconvId
+
 isNotifForUser :: (MakesValue user, MakesValue a, HasCallStack) => user -> a -> App Bool
 isNotifForUser user n = fieldEquals n "payload.0.data.qualified_user_ids.0" (objQidObject user)
 

diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs
@@ -402,3 +402,11 @@ uploadDownloadProfilePicture :: (HasCallStack, MakesValue usr) => usr -> App (St
 uploadDownloadProfilePicture usr = do
   (dom, key, _payload) <- uploadProfilePicture usr
   downloadProfilePicture usr dom key
+
+addUsersToFailureContext :: (MakesValue user) => [(String, user)] -> App a -> App a
+addUsersToFailureContext namesAndUsers action = do
+  let mkLine (name, user) = do
+        (domain, id_) <- objQid user
+        pure $ name <> ": " <> id_ <> "@" <> domain
+  allLines <- unlines <$> (mapM mkLine namesAndUsers)
+  addFailureContext allLines action
diff --git a/integration/test/Test/MLS/SubConversation.hs b/integration/test/Test/MLS/SubConversation.hs
@@ -236,86 +236,87 @@ testLeaveSubConv leaver = do
 testCreatorRemovesUserFromParent :: App ()
 testCreatorRemovesUserFromParent = do
   [alice, bob, charlie] <- createAndConnectUsers [OwnDomain, OwnDomain, OtherDomain]
-  [alice1, bob1, bob2, charlie1, charlie2] <- traverse (createMLSClient def def) [alice, bob, bob, charlie, charlie]
-  traverse_ (uploadNewKeyPackage def) [bob1, bob2, charlie1, charlie2]
-  (_, convId) <- createNewGroup def alice1
-
-  _ <- createAddCommit alice1 convId [bob, charlie] >>= sendAndConsumeCommitBundle
-
-  -- save the state of the parent group
-  -- parentState <- getMLSState
-  -- switch to the subgroup
-  let subConvName = "conference"
-  createSubConv def convId alice1 subConvName
-  subConvId <- getSubConvId alice convId "conference"
-
-  for_ [bob1, bob2, charlie1, charlie2] \c ->
-    createExternalCommit subConvId c Nothing >>= sendAndConsumeCommitBundle
-  -- save the state of the subgroup and switch to the parent context
-  -- childState <- getMLSState <* setMLSState parentState
-  withWebSockets [alice1, charlie1, charlie2] \wss -> do
-    removeCommitEvents <- createRemoveCommit alice1 convId [bob1, bob2] >>= sendAndConsumeCommitBundle
-    modifyMLSState $ \s ->
-      s
-        { convs =
-            Map.adjust
-              (\conv -> conv {members = conv.members Set.\\ Set.fromList [bob1, bob2]})
-              convId
-              s.convs
-        }
-
-    removeCommitEvents %. "events.0.type" `shouldMatch` "conversation.member-leave"
-    removeCommitEvents %. "events.0.data.reason" `shouldMatch` "removed"
-    removeCommitEvents %. "events.0.from" `shouldMatch` alice1.user
-
-    for_ wss \ws -> do
-      n <- awaitMatch isConvLeaveNotif ws
-      n %. "payload.0.data.reason" `shouldMatch` "removed"
-      n %. "payload.0.from" `shouldMatch` alice1.user
-
-    -- setMLSState childState
-    let idxBob1 :: Int = 1
-        idxBob2 :: Int = 2
-    for_ ((,) <$> [idxBob1, idxBob2] <*> wss) \(idx, ws) -> do
-      msg <-
-        awaitMatch
-          do
-            \n ->
-              isJust <$> runMaybeT do
-                msg <- lift $ n %. "payload.0.data" & asByteString >>= showMessage def alice1
-                guard =<< lift do
-                  isNewMLSMessageNotif n
-
-                prop <-
-                  maybe mzero pure =<< lift do
-                    lookupField msg "message.content.body.Proposal"
-
-                lift do
-                  (== idx) <$> (prop %. "Remove.removed" & asInt)
-          ws
-      for_ ws.client $ \consumer ->
-        msg %. "payload.0.data" & asByteString >>= mlsCliConsume def consumer
-
-    -- remove bob from the child state
-    modifyMLSState $ \s ->
-      s
-        { convs =
-            Map.adjust
-              (\conv -> conv {members = conv.members Set.\\ Set.fromList [bob1, bob2]})
-              subConvId
-              s.convs
-        }
-
-    _ <- createPendingProposalCommit subConvId alice1 >>= sendAndConsumeCommitBundle
-
-    getSubConversation bob convId subConvName >>= flip withResponse \resp ->
-      assertBool "access to the conversation for bob should be denied" (resp.status == 403)
-
-    for_ [charlie, alice] \m -> do
-      resp <- getSubConversation m convId subConvName
-      assertBool "alice and charlie should have access to the conversation" (resp.status == 200)
-      mems <- resp.jsonBody %. "members" & asList
-      mems `shouldMatchSet` ((renameField "id" "user_id" <=< make) `traverse` [alice1, charlie1, charlie2])
+  addUsersToFailureContext [("alice", alice), ("bob", bob), ("charlie", charlie)] $ do
+    [alice1, bob1, bob2, charlie1, charlie2] <- traverse (createMLSClient def def) [alice, bob, bob, charlie, charlie]
+    traverse_ (uploadNewKeyPackage def) [bob1, bob2, charlie1, charlie2]
+    (_, convId) <- createNewGroup def alice1
+
+    _ <- createAddCommit alice1 convId [bob, charlie] >>= sendAndConsumeCommitBundle
+
+    -- save the state of the parent group
+    -- parentState <- getMLSState
+    -- switch to the subgroup
+    let subConvName = "conference"
+    createSubConv def convId alice1 subConvName
+    subConvId <- getSubConvId alice convId "conference"
+
+    for_ [bob1, bob2, charlie1, charlie2] \c ->
+      createExternalCommit subConvId c Nothing >>= sendAndConsumeCommitBundle
+    -- save the state of the subgroup and switch to the parent context
+    -- childState <- getMLSState <* setMLSState parentState
+    withWebSockets [alice1, charlie1, charlie2] \wss -> do
+      removeCommitEvents <- createRemoveCommit alice1 convId [bob1, bob2] >>= sendAndConsumeCommitBundle
+      modifyMLSState $ \s ->
+        s
+          { convs =
+              Map.adjust
+                (\conv -> conv {members = conv.members Set.\\ Set.fromList [bob1, bob2]})
+                convId
+                s.convs
+          }
+
+      removeCommitEvents %. "events.0.type" `shouldMatch` "conversation.member-leave"
+      removeCommitEvents %. "events.0.data.reason" `shouldMatch` "removed"
+      removeCommitEvents %. "events.0.from" `shouldMatch` alice1.user
+
+      for_ wss \ws -> do
+        n <- awaitMatch isConvLeaveNotif ws
+        n %. "payload.0.data.reason" `shouldMatch` "removed"
+        n %. "payload.0.from" `shouldMatch` alice1.user
+
+      -- setMLSState childState
+      let idxBob1 :: Int = 1
+          idxBob2 :: Int = 2
+      for_ ((,) <$> [idxBob1, idxBob2] <*> wss) \(idx, ws) -> do
+        msg <-
+          awaitMatch
+            do
+              \n ->
+                isJust <$> runMaybeT do
+                  msg <- lift $ n %. "payload.0.data" & asByteString >>= showMessage def alice1
+                  guard =<< lift do
+                    isNewMLSMessageNotif n
+
+                  prop <-
+                    maybe mzero pure =<< lift do
+                      lookupField msg "message.content.body.Proposal"
+
+                  lift do
+                    (== idx) <$> (prop %. "Remove.removed" & asInt)
+            ws
+        for_ ws.client $ \consumer ->
+          msg %. "payload.0.data" & asByteString >>= mlsCliConsume def consumer
+
+      -- remove bob from the child state
+      modifyMLSState $ \s ->
+        s
+          { convs =
+              Map.adjust
+                (\conv -> conv {members = conv.members Set.\\ Set.fromList [bob1, bob2]})
+                subConvId
+                s.convs
+          }
+
+      _ <- createPendingProposalCommit subConvId alice1 >>= sendAndConsumeCommitBundle
+
+      getSubConversation bob convId subConvName >>= flip withResponse \resp ->
+        assertBool "access to the conversation for bob should be denied" (resp.status == 403)
+
+      for_ [charlie, alice] \m -> do
+        resp <- getSubConversation m convId subConvName
+        assertBool "alice and charlie should have access to the conversation" (resp.status == 200)
+        mems <- resp.jsonBody %. "members" & asList
+        mems `shouldMatchSet` ((renameField "id" "user_id" <=< make) `traverse` [alice1, charlie1, charlie2])
 
 testResendingProposals :: (HasCallStack) => App ()
 testResendingProposals = do