[FS-901] Tests for joining subconversation

changelog.d/5-internal/test-joining-subconversation

@@ -0,0 +1 @@
+Add more tests for joining a subconversation

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

@@ -29,7 +29,8 @@ where
 import Control.Arrow ((>>>))
 import Control.Comonad
 import Control.Error.Util (hush)
-import Control.Lens (preview)
+import Control.Lens (forOf_, preview)
+import Control.Lens.Extras (is)
 import Data.Id
 import Data.Json.Util
 import Data.List.NonEmpty (NonEmpty, nonEmpty)
@@ -785,11 +786,10 @@ processExternalCommit qusr mSenderClient lConvOrSub epoch action updatePath = wi
     throw . mlsProtocolError $
       "The external commit attempts to add another client of the user, it must only add itself"
 
-  case convOrSub of
-    Conv _ -> pure ()
-    SubConv mlsConv _ ->
-      unless (isClientMember cid (mcMembers mlsConv)) $
-        throwS @'MLSSubConvClientNotInParent
+  -- only members can join a subconversation
+  forOf_ _SubConv convOrSub $ \(mlsConv, _) ->
+    unless (isClientMember cid (mcMembers mlsConv)) $
+      throwS @'MLSSubConvClientNotInParent
 
   -- check if there is a key package ref in the remove proposal
   remRef <-
@@ -982,7 +982,7 @@ processInternalCommit qusr senderClient con lConvOrSub epoch action senderRef co
       throwS @'MLSCommitMissingReferences
 
     -- process and execute proposals
-    updates <- executeProposalAction lConvOrSub qusr con convOrSub action
+    updates <- executeProposalAction qusr con lConvOrSub action
 
     -- update key package ref if necessary
     postponedKeyPackageRefUpdate
@@ -1218,8 +1218,7 @@ checkExternalProposalUser qusr prop = do
     (const $ pure ()) -- FUTUREWORK: check external proposals from remote backends
     qusr
 
-executeProposalAction ::
-  forall r x.
+type HasProposalActionEffects r =
   ( Member BrigAccess r,
     Member ConversationStore r,
     Member (Error InternalError) r,
@@ -1244,44 +1243,51 @@ executeProposalAction ::
     Member TinyLog r,
     CallsFed 'Galley "on-conversation-updated",
     CallsFed 'Galley "on-mls-message-sent",
-    CallsFed 'Galley "on-new-remote-conversation",
+    CallsFed 'Galley "on-new-remote-conversation"
+  )
+
+executeProposalAction ::
+  forall r.
+  ( HasProposalActionEffects r,
     CallsFed 'Brig "get-mls-clients"
   ) =>
-  Local x ->
   Qualified UserId ->
   Maybe ConnId ->
-  ConvOrSubConv ->
+  Local ConvOrSubConv ->
   ProposalAction ->
   Sem r [LocalConversationUpdate]
-executeProposalAction _loc _qusr _con (SubConv _ _) _action = pure []
-executeProposalAction loc qusr con (Conv mlsConv) action = do
-  let lconv = qualifyAs loc . mcConv $ mlsConv
-      mlsMeta = mcMLSData mlsConv
-      cm = mcMembers mlsConv
+executeProposalAction qusr con lconvOrSub action = do
+  let convOrSub = tUnqualified lconvOrSub
+      mlsMeta = mlsMetaConvOrSub convOrSub
+      cm = membersConvOrSub convOrSub
       ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta)
       newUserClients = Map.assocs (paAdd action)
 
+  -- no client can be directly added to a subconversation
+  when (is _SubConv convOrSub && not (null newUserClients)) $
+    throw (mlsProtocolError "Add proposals in subconversations are not supported")
+
   -- Note [client removal]
   -- We support two types of removals:
   --  1. when a user is removed from a group, all their clients have to be removed
   --  2. when a client is deleted, that particular client (but not necessarily
-  --     other clients of the same user), has to be removed.
+  --     other clients of the same user) has to be removed.
   --
   -- 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, Map.keysSet -> clients) -> runError @() $ do
       -- fetch clients from brig
-      clientInfo <- Set.map ciId <$> getClientInfo lconv qtarget ss
+      clientInfo <- Set.map ciId <$> getClientInfo lconvOrSub 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)
 
   -- FUTUREWORK: remove this check after remote admins are implemented in federation https://wearezeta.atlassian.net/browse/FS-216
-  foldQualified lconv (\_ -> pure ()) (\_ -> throwS @'MLSUnsupportedProposal) qusr
+  foldQualified lconvOrSub (\_ -> 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
@@ -1292,7 +1298,7 @@ executeProposalAction loc qusr con (Conv mlsConv) action = do
       -- final set of clients in the conversation
       let clients = Map.keysSet (newclients <> Map.findWithDefault mempty qtarget cm)
       -- get list of mls clients from brig
-      clientInfo <- getClientInfo lconv qtarget ss
+      clientInfo <- getClientInfo lconvOrSub qtarget ss
       let allClients = Set.map ciId clientInfo
       let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo)
       -- We check the following condition:
@@ -1316,14 +1322,21 @@ executeProposalAction loc qusr con (Conv mlsConv) action = do
   membersToRemove <- catMaybes <$> for removedUsers (uncurry (checkRemoval cm))
 
   -- add users to the conversation and send events
-  addEvents <- foldMap (addMembers lconv) . nonEmpty . map fst $ newUserClients
+  addEvents <-
+    foldMap (addMembers qusr con lconvOrSub)
+      . nonEmpty
+      . map fst
+      $ newUserClients
 
   -- add clients in the conversation state
   for_ newUserClients $ \(qtarget, newClients) -> do
     addMLSClients (cnvmlsGroupId mlsMeta) qtarget (Set.fromList (Map.assocs newClients))
 
   -- remove users from the conversation and send events
-  removeEvents <- foldMap (removeMembers lconv) (nonEmpty membersToRemove)
+  removeEvents <-
+    foldMap
+      (removeMembers qusr con lconvOrSub)
+      (nonEmpty membersToRemove)
 
   -- Remove clients from the conversation state. This includes client removals
   -- of all types (see Note [client removal]).
@@ -1346,43 +1359,63 @@ executeProposalAction loc qusr con (Conv mlsConv) action = do
         throwS @'MLSSelfRemovalNotAllowed
       pure (Just qtarget)
 
-    existingLocalMembers :: Local Data.Conversation -> Set (Qualified UserId)
-    existingLocalMembers lconv =
-      (Set.fromList . map (fmap lmId . tUntagged)) (traverse convLocalMembers lconv)
-
-    existingRemoteMembers :: Local Data.Conversation -> Set (Qualified UserId)
-    existingRemoteMembers lconv =
-      Set.fromList . map (tUntagged . rmId) . convRemoteMembers . tUnqualified $
-        lconv
-
-    existingMembers :: Local Data.Conversation -> Set (Qualified UserId)
-    existingMembers lconv = existingLocalMembers lconv <> existingRemoteMembers lconv
-
-    addMembers :: Local Data.Conversation -> NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate]
-    addMembers lconv =
-      -- FUTUREWORK: update key package ref mapping to reflect conversation membership
-      foldMap
-        ( handleNoChanges
-            . handleMLSProposalFailures @ProposalErrors
-            . fmap pure
-            . updateLocalConversationUnchecked @'ConversationJoinTag lconv qusr con
-            . flip ConversationJoin roleNameWireMember
-        )
-        . nonEmpty
-        . filter (flip Set.notMember (existingMembers lconv))
-        . toList
-
-    removeMembers :: Local Data.Conversation -> NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate]
-    removeMembers lconv =
-      foldMap
-        ( handleNoChanges
-            . handleMLSProposalFailures @ProposalErrors
-            . fmap pure
-            . updateLocalConversationUnchecked @'ConversationRemoveMembersTag lconv qusr con
-        )
-        . nonEmpty
-        . filter (flip Set.member (existingMembers lconv))
-        . toList
+existingLocalMembers :: Local Data.Conversation -> Set (Qualified UserId)
+existingLocalMembers lconv =
+  (Set.fromList . map (fmap lmId . tUntagged)) (traverse convLocalMembers lconv)
+
+existingRemoteMembers :: Local Data.Conversation -> Set (Qualified UserId)
+existingRemoteMembers lconv =
+  Set.fromList . map (tUntagged . rmId) . convRemoteMembers . tUnqualified $
+    lconv
+
+existingMembers :: Local Data.Conversation -> Set (Qualified UserId)
+existingMembers lconv = existingLocalMembers lconv <> existingRemoteMembers lconv
+
+addMembers ::
+  HasProposalActionEffects r =>
+  Qualified UserId ->
+  Maybe ConnId ->
+  Local ConvOrSubConv ->
+  NonEmpty (Qualified UserId) ->
+  Sem r [LocalConversationUpdate]
+addMembers qusr con lconvOrSub users = case tUnqualified lconvOrSub of
+  Conv mlsConv -> do
+    let lconv = qualifyAs lconvOrSub (mcConv mlsConv)
+    -- FUTUREWORK: update key package ref mapping to reflect conversation membership
+    foldMap
+      ( handleNoChanges
+          . handleMLSProposalFailures @ProposalErrors
+          . fmap pure
+          . updateLocalConversationUnchecked @'ConversationJoinTag lconv qusr con
+          . flip ConversationJoin roleNameWireMember
+      )
+      . nonEmpty
+      . filter (flip Set.notMember (existingMembers lconv))
+      . toList
+      $ users
+  SubConv _ _ -> pure []
+
+removeMembers ::
+  HasProposalActionEffects r =>
+  Qualified UserId ->
+  Maybe ConnId ->
+  Local ConvOrSubConv ->
+  NonEmpty (Qualified UserId) ->
+  Sem r [LocalConversationUpdate]
+removeMembers qusr con lconvOrSub users = case tUnqualified lconvOrSub of
+  Conv mlsConv -> do
+    let lconv = qualifyAs lconvOrSub (mcConv mlsConv)
+    foldMap
+      ( handleNoChanges
+          . handleMLSProposalFailures @ProposalErrors
+          . fmap pure
+          . updateLocalConversationUnchecked @'ConversationRemoveMembersTag lconv qusr con
+      )
+      . nonEmpty
+      . filter (flip Set.member (existingMembers lconv))
+      . toList
+      $ users
+  SubConv _ _ -> pure []
 
 handleNoChanges :: Monoid a => Sem (Error NoChanges ': r) a -> Sem r a
 handleNoChanges = fmap fold . runError

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

@@ -214,8 +214,8 @@ tests s =
             [ test s "get subconversation of MLS conv - 200" (testCreateSubConv True),
               test s "get subconversation of Proteus conv - 404" (testCreateSubConv False),
               test s "join subconversation with an external commit bundle" testJoinSubConv,
-              test s "join subconversation with a client that is not in the main conv" testJoinSubNonMemberClient,
-              test s "add another client to a subconversation" testAddClientSubConv,
+              test s "join subconversation with a client that is not in the parent conv" testJoinSubNonMemberClient,
+              test s "fail to add another client to a subconversation via internal commit" testAddClientSubConv,
               test s "remove another client from a subconversation" testRemoveClientSubConv,
               test s "send an application message in a subconversation" testSendMessageSubConv,
               test s "reset a subconversation as a member" (testDeleteSubConv True),
@@ -2361,7 +2361,7 @@ testJoinSubConv = do
       sub <-
         liftTest $
           responseJsonError
-            =<< getSubConv (qUnqualified bob) qcnv (SubConvId "conference")
+            =<< getSubConv (qUnqualified bob) qcnv subId
               <!! const 200 === statusCode
 
       resetGroup bob1 (pscGroupId sub)
@@ -2381,13 +2381,63 @@ testJoinSubConv = do
         createExternalCommit alice1 Nothing (fmap (flip SubConv subId) qcnv)
           >>= sendAndConsumeCommitBundle
 
--- FUTUREWORK: implement the following tests
-
 testJoinSubNonMemberClient :: TestM ()
-testJoinSubNonMemberClient = pure ()
+testJoinSubNonMemberClient = do
+  [alice, bob] <- createAndConnectUsers [Nothing, Nothing]
+
+  runMLSTest $ do
+    [alice1, alice2, bob1] <-
+      traverse createMLSClient [alice, alice, bob]
+    traverse_ uploadNewKeyPackage [bob1, alice2]
+    (_, qcnv) <- setupMLSGroup alice1
+    void $ createAddCommit alice1 [alice] >>= sendAndConsumeCommit
+
+    let subId = SubConvId "conference"
+    void $ createSubConv qcnv alice1 subId
+
+    -- now Bob attempts to get the group info so he can join via external commit
+    -- with his own client, but he cannot because he is not a member of the
+    -- parent conversation
+    getGroupInfo (ciUser bob1) (fmap (flip SubConv subId) qcnv)
+      !!! const 404 === statusCode
 
 testAddClientSubConv :: TestM ()
-testAddClientSubConv = pure ()
+testAddClientSubConv = do
+  [alice, bob] <- createAndConnectUsers [Nothing, Nothing]
+  runMLSTest $ do
+    [alice1, bob1] <- traverse createMLSClient [alice, bob]
+    void $ uploadNewKeyPackage bob1
+    (_, qcnv) <- setupMLSGroup alice1
+    void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit
+
+    let subId = SubConvId "conference"
+    void $ createSubConv qcnv alice1 subId
+
+    void $ uploadNewKeyPackage bob1
+
+    commit <- createAddCommit alice1 [bob]
+    (createBundle commit >>= postCommitBundle (mpSender commit))
+      !!! do
+        const 400 === statusCode
+        const (Just "Add proposals in subconversations are not supported")
+          === fmap Wai.message . responseJsonError
+
+    finalSub <-
+      liftTest $
+        responseJsonError
+          =<< getSubConv (qUnqualified alice) qcnv subId
+            <!! const 200 === statusCode
+    liftIO $ do
+      assertEqual
+        "The subconversation has Bob in it, while it shouldn't"
+        [alice1]
+        (pscMembers finalSub)
+      assertEqual
+        "The subconversation epoch has moved beyond 1"
+        (Epoch 1)
+        (pscEpoch finalSub)
+
+-- FUTUREWORK: implement the following tests
 
 testRemoveClientSubConv :: TestM ()
 testRemoveClientSubConv = pure ()
@@ -2409,9 +2459,9 @@ testSendMessageSubConv = do
       (_, qcnv) <- setupMLSGroup alice1
       void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit
 
-      let subname = "conference"
-      void $ createSubConv qcnv bob1 subname
-      let qcs = convsub qcnv (Just subname)
+      let subId = SubConvId "conference"
+      void $ createSubConv qcnv bob1 subId
+      let qcs = convsub qcnv (Just subId)
 
       void $ createExternalCommit alice1 Nothing qcs >>= sendAndConsumeCommitBundle
       void $ createExternalCommit bob2 Nothing qcs >>= sendAndConsumeCommitBundle
@@ -2602,7 +2652,7 @@ testDeleteSubConv isAMember = do
   (qcnv, sub) <- runMLSTest $ do
     alice1 <- createMLSClient alice
     (_, qcnv) <- setupMLSGroup alice1
-    sub <- createSubConv qcnv alice1 (unSubConvId sconv)
+    sub <- createSubConv qcnv alice1 sconv
     pure (qcnv, sub)
 
   let dsc = DeleteSubConversation (pscGroupId sub) (pscEpoch sub)

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

@@ -462,10 +462,9 @@ resetGroup cid gid = do
 createSubConv ::
   Qualified ConvId ->
   ClientIdentity ->
-  Text ->
+  SubConvId ->
   MLSTest PublicSubConversation
-createSubConv qcnv creator name = do
-  let subId = SubConvId name
+createSubConv qcnv creator subId = do
   sub <-
     liftTest $
       responseJsonError
@@ -1125,6 +1124,6 @@ deleteSubConv u qcnv sconv dsc = do
       . contentJson
       . json dsc
 
-convsub :: Qualified ConvId -> Maybe Text -> Qualified ConvOrSubConvId
+convsub :: Qualified ConvId -> Maybe SubConvId -> Qualified ConvOrSubConvId
 convsub qcnv Nothing = Conv <$> qcnv
-convsub qcnv (Just subname) = flip SubConv (SubConvId subname) <$> qcnv
+convsub qcnv (Just sconv) = flip SubConv sconv <$> qcnv