Create subconversations on first commit

changelog.d/5-internal/mls-subconv-creation

@@ -0,0 +1 @@
+Subconversations are now created on their first commit

integration/integration.cabal

@@ -94,6 +94,7 @@ library
     Test.MLS
     Test.MLS.KeyPackage
     Test.MLS.One2One
+    Test.MLS.SubConversation
     Test.User
     Testlib.App
     Testlib.Assertions

integration/test/API/Galley.hs

@@ -117,6 +117,21 @@ getSubConversation user conv sub = do
         ]
   submit "GET" req
 
+deleteSubConversation ::
+  (HasCallStack, MakesValue user, MakesValue sub) =>
+  user ->
+  sub ->
+  App Response
+deleteSubConversation user sub = do
+  (conv, Just subId) <- objSubConv sub
+  (domain, convId) <- objQid conv
+  groupId <- sub %. "group_id" & asString
+  epoch :: Int <- sub %. "epoch" & asIntegral
+  req <-
+    baseRequest user Galley Versioned $
+      joinHttpPath ["conversations", domain, convId, "subconversations", subId]
+  submit "DELETE" $ req & addJSONObject ["group_id" .= groupId, "epoch" .= epoch]
+
 getSelfConversation :: (HasCallStack, MakesValue user) => user -> App Response
 getSelfConversation user = do
   req <- baseRequest user Galley Versioned "/conversations/mls-self"

integration/test/MLS/Util.hs

@@ -193,9 +193,16 @@ createGroup cid conv = do
     Nothing -> pure ()
   resetGroup cid conv
 
+createSubConv :: ClientIdentity -> String -> App ()
+createSubConv cid subId = do
+  mls <- getMLSState
+  sub <- getSubConversation cid mls.convId subId >>= getJSON 200
+  resetGroup cid sub
+  void $ createPendingProposalCommit cid >>= sendAndConsumeCommitBundle
+
 resetGroup :: MakesValue conv => ClientIdentity -> conv -> App ()
 resetGroup cid conv = do
-  convId <- make conv
+  convId <- objSubConvObject conv
   groupId <- conv %. "group_id" & asString
   modifyMLSState $ \s ->
     s

integration/test/Test/MLS.hs

@@ -351,17 +351,11 @@ testJoinSubConv = do
   traverse_ uploadNewKeyPackage [bob1, bob2]
   (_, qcnv) <- createNewGroup alice1
   void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle
-
-  sub <- bindResponse (getSubConversation bob qcnv "conference") $ \resp -> do
-    resp.status `shouldMatchInt` 200
-    resp.json
-  resetGroup bob1 sub
+  void $ createSubConv bob1 "conference"
 
   -- bob adds his first client to the subconversation
   void $ createPendingProposalCommit bob1 >>= sendAndConsumeCommitBundle
-  sub' <- bindResponse (getSubConversation bob qcnv "conference") $ \resp -> do
-    resp.status `shouldMatchInt` 200
-    resp.json
+  sub' <- getSubConversation bob qcnv "conference" >>= getJSON 200
   do
     tm <- sub' %. "epoch_timestamp"
     assertBool "Epoch timestamp should not be null" (tm /= Null)
@@ -381,11 +375,7 @@ testDeleteParentOfSubConv secondDomain = do
   traverse_ uploadNewKeyPackage [alice1, bob1]
   (_, qcnv) <- createNewGroup alice1
   void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle
-
-  sub <- bindResponse (getSubConversation bob qcnv "conference") $ \resp -> do
-    resp.status `shouldMatchInt` 200
-    resp.json
-  resetGroup bob1 sub
+  void $ createSubConv bob1 "conference"
 
   -- bob adds his client to the subconversation
   void $ createPendingProposalCommit bob1 >>= sendAndConsumeCommitBundle

integration/test/Test/MLS/SubConversation.hs

@@ -0,0 +1,98 @@
+module Test.MLS.SubConversation where
+
+import API.Galley
+import MLS.Util
+import SetupHelpers
+import Testlib.Prelude
+
+testJoinSubConv :: App ()
+testJoinSubConv = do
+  [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain]
+  [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob]
+  traverse_ uploadNewKeyPackage [bob1, bob2]
+  (_, qcnv) <- createNewGroup alice1
+  void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle
+  createSubConv bob1 "conference"
+
+  -- bob adds his first client to the subconversation
+  void $ createPendingProposalCommit bob1 >>= sendAndConsumeCommitBundle
+  sub' <- getSubConversation bob qcnv "conference" >>= getJSON 200
+  do
+    tm <- sub' %. "epoch_timestamp"
+    assertBool "Epoch timestamp should not be null" (tm /= Null)
+
+  -- now alice joins with her own client
+  void $
+    createExternalCommit alice1 Nothing
+      >>= sendAndConsumeCommitBundle
+
+testDeleteParentOfSubConv :: HasCallStack => Domain -> App ()
+testDeleteParentOfSubConv secondDomain = do
+  (alice, tid) <- createTeam OwnDomain
+  bob <- randomUser secondDomain def
+  connectUsers [alice, bob]
+
+  [alice1, bob1] <- traverse createMLSClient [alice, bob]
+  traverse_ uploadNewKeyPackage [alice1, bob1]
+  (_, qcnv) <- createNewGroup alice1
+  void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle
+  createSubConv bob1 "conference"
+
+  -- bob adds his client to the subconversation
+  void $ createPendingProposalCommit bob1 >>= sendAndConsumeCommitBundle
+
+  -- alice joins with her own client
+  void $ createExternalCommit alice1 Nothing >>= sendAndConsumeCommitBundle
+
+  -- bob sends a message to the subconversation
+  do
+    mp <- createApplicationMessage bob1 "hello, alice"
+    void . bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do
+      resp.status `shouldMatchInt` 201
+
+  -- alice sends a message to the subconversation
+  do
+    mp <- createApplicationMessage bob1 "hello, bob"
+    void . bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do
+      resp.status `shouldMatchInt` 201
+
+  -- alice deletes main conversation
+  void . bindResponse (deleteTeamConv tid qcnv alice) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+
+  -- bob fails to send a message to the subconversation
+  do
+    mp <- createApplicationMessage bob1 "hello, alice"
+    void . bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do
+      resp.status `shouldMatchInt` 404
+      case secondDomain of
+        OwnDomain -> resp.json %. "label" `shouldMatch` "no-conversation"
+        OtherDomain -> resp.json %. "label" `shouldMatch` "no-conversation-member"
+
+  -- alice fails to send a message to the subconversation
+  do
+    mp <- createApplicationMessage alice1 "hello, bob"
+    void . bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do
+      resp.status `shouldMatchInt` 404
+      resp.json %. "label" `shouldMatch` "no-conversation"
+
+testDeleteSubConversation :: HasCallStack => Domain -> App ()
+testDeleteSubConversation otherDomain = do
+  [alice, bob] <- createAndConnectUsers [OwnDomain, otherDomain]
+  charlie <- randomUser OwnDomain def
+  [alice1, bob1] <- traverse createMLSClient [alice, bob]
+  void $ uploadNewKeyPackage bob1
+  (_, qcnv) <- createNewGroup alice1
+  void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle
+
+  createSubConv alice1 "conference1"
+  sub1 <- getSubConversation alice qcnv "conference1" >>= getJSON 200
+  void $ deleteSubConversation charlie sub1 >>= getBody 403
+  void $ deleteSubConversation alice sub1 >>= getBody 200
+
+  createSubConv alice1 "conference2"
+  sub2 <- getSubConversation alice qcnv "conference2" >>= getJSON 200
+  void $ deleteSubConversation bob sub2 >>= getBody 200
+
+  sub2' <- getSubConversation alice1 qcnv "conference2" >>= getJSON 200
+  sub2 `shouldNotMatch` sub2'

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

@@ -72,6 +72,9 @@ getExternalCommitData senderIdentity lConvOrSub epoch commit = do
       curEpoch = cnvmlsEpoch convOrSub.meta
       groupId = cnvmlsGroupId convOrSub.meta
   when (epoch /= curEpoch) $ throwS @'MLSStaleMessage
+  when (epoch == Epoch 0) $
+    throw $
+      mlsProtocolError "The first commit in a group cannot be external"
   proposals <- traverse getInlineProposal commit.proposals
 
   -- According to the spec, an external commit must contain:

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

@@ -38,6 +38,7 @@ import qualified Galley.Data.Conversation.Types as Data
 import Galley.Effects
 import Galley.Effects.MemberStore
 import Galley.Effects.ProposalStore
+import Galley.Effects.SubConversationStore
 import Galley.Types.Conversations.Members
 import Imports
 import Polysemy
@@ -165,6 +166,22 @@ processInternalCommit senderIdentity con lConvOrSub epoch action commit = do
                     pure Nothing
           for_ (unreachableFromList failedAddFetching) throwUnreachableUsers
 
+          -- Some types of conversations are created lazily on the first
+          -- commit. We do that here, with the commit lock held, but before
+          -- applying changes to the member list.
+          case convOrSub.id of
+            SubConv cnv sub | epoch == Epoch 0 -> do
+              -- create subconversation if it doesn't exist
+              msub' <- getSubConversation cnv sub
+              when (isNothing msub') $
+                void $
+                  createSubConversation
+                    cnv
+                    sub
+                    convOrSub.meta.cnvmlsCipherSuite
+                    convOrSub.meta.cnvmlsGroupId
+            _ -> pure () -- FUTUREWORK: create 1-1 conversation at epoch 0
+
           -- remove users from the conversation and send events
           removeEvents <-
             foldMap

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

@@ -205,7 +205,9 @@ postMLSCommitBundleToLocalConv qusr c conn bundle lConvOrSubId = do
 
   (events, newClients) <- case bundle.sender of
     SenderMember _index -> do
+      -- extract added/removed clients from bundle
       action <- getCommitData senderIdentity lConvOrSub bundle.epoch bundle.commit.value
+      -- process additions and removals
       events <-
         processInternalCommit
           senderIdentity
@@ -445,7 +447,8 @@ fetchConvOrSub qusr convOrSubId = for convOrSubId $ \case
   SubConv convId sconvId -> do
     let lconv = qualifyAs convOrSubId convId
     c <- getMLSConv qusr lconv
-    subconv <- getSubConversation convId sconvId >>= noteS @'ConvNotFound
+    msubconv <- getSubConversation convId sconvId
+    let subconv = fromMaybe (newSubConversationFromParent lconv sconvId (mcMLSData c)) msubconv
     pure (SubConv c subconv)
   where
     getMLSConv :: Qualified UserId -> Local ConvId -> Sem r MLSConversation

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

@@ -125,30 +125,9 @@ getLocalSubConversation qusr lconv sconv = do
         MLSMigrationMixed -> throwS @'MLSSubConvUnsupportedConvType
         MLSMigrationMLS -> pure ()
 
-      -- deriving this detemernistically to prevent race condition between
+      -- deriving this deterministically to prevent race conditions with
       -- multiple threads creating the subconversation
-      let groupId =
-            convToGroupId
-              . groupIdParts (Data.convType c)
-              $ flip SubConv sconv <$> tUntagged lconv
-          epoch = Epoch 0
-          suite = cnvmlsCipherSuite mlsMeta
-      Eff.createSubConversation (tUnqualified lconv) sconv suite epoch groupId Nothing
-      let sub =
-            SubConversation
-              { scParentConvId = tUnqualified lconv,
-                scSubConvId = sconv,
-                scMLSData =
-                  ConversationMLSData
-                    { cnvmlsGroupId = groupId,
-                      cnvmlsEpoch = epoch,
-                      cnvmlsEpochTimestamp = Nothing,
-                      cnvmlsCipherSuite = suite
-                    },
-                scMembers = mkClientMap [],
-                scIndexMap = mempty
-              }
-      pure sub
+      pure (newSubConversationFromParent lconv sconv mlsMeta)
     Just sub -> pure sub
   pure (toPublicSubConv (tUntagged (qualifyAs lconv sub)))
 
@@ -307,7 +286,7 @@ deleteLocalSubConversation qusr lcnvId scnvId dsc = do
             $ nextGenGroupId gid
 
     -- the following overwrites any prior information about the subconversation
-    Eff.createSubConversation cnvId scnvId cs (Epoch 0) newGid Nothing
+    void $ Eff.createSubConversation cnvId scnvId cs newGid
 
 deleteRemoteSubConversation ::
   ( Members

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

@@ -30,7 +30,9 @@ import Galley.Types.Conversations.Members
 import Imports
 import Wire.API.Conversation
 import Wire.API.Conversation.Protocol
+import Wire.API.MLS.CipherSuite
 import Wire.API.MLS.Credential
+import Wire.API.MLS.Group.Serialisation
 import Wire.API.MLS.LeafNode
 import Wire.API.MLS.SubConversation
 
@@ -146,6 +148,35 @@ data SubConversation = SubConversation
   }
   deriving (Eq, Show)
 
+newSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> GroupId -> SubConversation
+newSubConversation convId subConvId suite groupId =
+  SubConversation
+    { scParentConvId = convId,
+      scSubConvId = subConvId,
+      scMLSData =
+        ConversationMLSData
+          { cnvmlsGroupId = groupId,
+            cnvmlsEpoch = Epoch 0,
+            cnvmlsEpochTimestamp = Nothing,
+            cnvmlsCipherSuite = suite
+          },
+      scMembers = mkClientMap [],
+      scIndexMap = mempty
+    }
+
+newSubConversationFromParent ::
+  Local ConvId ->
+  SubConvId ->
+  ConversationMLSData ->
+  SubConversation
+newSubConversationFromParent lconv sconv mlsMeta =
+  let groupId =
+        convToGroupId
+          . groupIdParts RegularConv
+          $ flip SubConv sconv <$> tUntagged lconv
+      suite = cnvmlsCipherSuite mlsMeta
+   in newSubConversation (tUnqualified lconv) sconv suite groupId
+
 toPublicSubConv :: Qualified SubConversation -> PublicSubConversation
 toPublicSubConv (Qualified (SubConversation {..}) domain) =
   let members = map fst (cmAssocs scMembers)

services/galley/src/Galley/Cassandra/SubConversation.hs

@@ -63,12 +63,19 @@ insertSubConversation ::
   ConvId ->
   SubConvId ->
   CipherSuiteTag ->
-  Epoch ->
   GroupId ->
-  Maybe GroupInfoData ->
-  Client ()
-insertSubConversation convId subConvId suite epoch groupId mGroupInfo =
-  retry x5 (write Cql.insertSubConversation (params LocalQuorum (convId, subConvId, suite, epoch, groupId, mGroupInfo)))
+  Client SubConversation
+insertSubConversation convId subConvId suite groupId = do
+  retry
+    x5
+    ( write
+        Cql.insertSubConversation
+        ( params
+            LocalQuorum
+            (convId, subConvId, suite, Epoch 0, groupId, Nothing)
+        )
+    )
+  pure (newSubConversation convId subConvId suite groupId)
 
 updateSubConvGroupInfo :: ConvId -> SubConvId -> Maybe GroupInfoData -> Client ()
 updateSubConvGroupInfo convId subConvId mGroupInfo =
@@ -110,8 +117,8 @@ interpretSubConversationStoreToCassandra ::
   Sem (SubConversationStore ': r) a ->
   Sem r a
 interpretSubConversationStoreToCassandra = interpret $ \case
-  CreateSubConversation convId subConvId suite epoch groupId mGroupInfo ->
-    embedClient (insertSubConversation convId subConvId suite epoch groupId mGroupInfo)
+  CreateSubConversation convId subConvId suite groupId ->
+    embedClient (insertSubConversation convId subConvId suite groupId)
   GetSubConversation convId subConvId -> embedClient (selectSubConversation convId subConvId)
   GetSubConversationGroupInfo convId subConvId -> embedClient (selectSubConvGroupInfo convId subConvId)
   GetSubConversationEpoch convId subConvId -> embedClient (selectSubConvEpoch convId subConvId)

services/galley/src/Galley/Effects/SubConversationStore.hs

@@ -30,7 +30,7 @@ import Wire.API.MLS.GroupInfo
 import Wire.API.MLS.SubConversation
 
 data SubConversationStore m a where
-  CreateSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> Epoch -> GroupId -> Maybe GroupInfoData -> SubConversationStore m ()
+  CreateSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> GroupId -> SubConversationStore m SubConversation
   GetSubConversation :: ConvId -> SubConvId -> SubConversationStore m (Maybe SubConversation)
   GetSubConversationGroupInfo :: ConvId -> SubConvId -> SubConversationStore m (Maybe GroupInfoData)
   GetSubConversationEpoch :: ConvId -> SubConvId -> SubConversationStore m (Maybe Epoch)