add new generation to GroupId

libs/wire-api/src/Wire/API/MLS/Group.hs

@@ -44,3 +44,7 @@ instance ToSchema GroupId where
     GroupId
       <$> unGroupId
         .= named "GroupId" (Base64ByteString .= fmap fromBase64ByteString (unnamed schema))
+
+newtype GroupIdGen = GroupIdGen {unGroupIdGen :: Word32}
+  deriving (Eq, Show, Generic, Ord)
+  deriving (Arbitrary) via (GenericUniform GroupIdGen)

libs/wire-api/src/Wire/API/MLS/Group/Serialisation.hs

@@ -17,7 +17,9 @@
 
 module Wire.API.MLS.Group.Serialisation
   ( convToGroupId,
+    convToGroupId',
     groupIdToConv,
+    nextGenGroupId,
   )
 where
 
@@ -39,21 +41,25 @@ import Wire.API.MLS.SubConversation
 
 -- | Return the group ID associated to a conversation ID. Note that is not
 -- assumed to be stable over time or even consistent among different backends.
-convToGroupId :: Qualified ConvOrSubConvId -> GroupId
-convToGroupId qcs = GroupId . L.toStrict . runPut $ do
+convToGroupId :: Qualified ConvOrSubConvId -> GroupIdGen -> GroupId
+convToGroupId qcs gen = GroupId . L.toStrict . runPut $ do
   let cs = qUnqualified qcs
       subId = foldMap unSubConvId cs.subconv
   putWord64be 1 -- Version 1 of the GroupId format
   putLazyByteString . UUID.toByteString . toUUID $ cs.conv
   putWord8 $ fromIntegral (T.length subId)
   putByteString $ T.encodeUtf8 subId
+  maybe (pure ()) (const $ putWord32be (unGroupIdGen gen)) cs.subconv
   putLazyByteString . toByteString $ qDomain qcs
 
-groupIdToConv :: GroupId -> Either String (Qualified ConvOrSubConvId)
+convToGroupId' :: Qualified ConvOrSubConvId -> GroupId
+convToGroupId' = flip convToGroupId (GroupIdGen 0)
+
+groupIdToConv :: GroupId -> Either String (Qualified ConvOrSubConvId, GroupIdGen)
 groupIdToConv gid = do
-  (rem', _, conv) <- first (\(_, _, msg) -> msg) $ runGetOrFail readConv (L.fromStrict (unGroupId gid))
+  (rem', _, (conv, gen)) <- first (\(_, _, msg) -> msg) $ runGetOrFail readConv (L.fromStrict (unGroupId gid))
   domain <- first displayException . T.decodeUtf8' . L.toStrict $ rem'
-  pure $ Qualified conv (Domain domain)
+  pure $ (Qualified conv (Domain domain), gen)
   where
     readConv = do
       version <- getWord64be
@@ -62,8 +68,15 @@ groupIdToConv gid = do
       uuid <- maybe (fail "invalid conversation UUID in groupId") pure mUUID
       n <- getWord8
       if n == 0
-        then pure $ Conv (Id uuid)
+        then pure $ (Conv (Id uuid), GroupIdGen 0)
         else do
           subConvIdBS <- getByteString $ fromIntegral n
           subConvId <- either (fail . T.unpack) pure $ parseHeader subConvIdBS
-          pure $ SubConv (Id uuid) (SubConvId subConvId)
+          gen <- getWord32be
+          pure $ (SubConv (Id uuid) (SubConvId subConvId), GroupIdGen gen)
+
+nextGenGroupId :: GroupId -> Either String GroupId
+nextGenGroupId gid =
+  uncurry convToGroupId
+    . second (GroupIdGen . succ . unGroupIdGen)
+    <$> groupIdToConv gid

libs/wire-api/test/unit/Test/Wire/API/MLS/Group.hs

@@ -22,8 +22,9 @@ import Imports
 import Test.QuickCheck
 import Test.Tasty
 import Test.Tasty.QuickCheck
+import Wire.API.MLS.Group
 import Wire.API.MLS.Group.Serialisation
-import Wire.API.MLS.SubConversation (ConvOrSubConvId)
+import Wire.API.MLS.SubConversation
 
 tests :: TestTree
 tests =
@@ -32,5 +33,9 @@ tests =
     [ testProperty "roundtrip serialise and parse groupId" $ roundtripGroupId
     ]
 
-roundtripGroupId :: Qualified ConvOrSubConvId -> Property
-roundtripGroupId convId = groupIdToConv (convToGroupId convId) === Right convId
+roundtripGroupId :: Qualified ConvOrSubConvId -> GroupIdGen -> Property
+roundtripGroupId convId gen =
+  let gen' = case qUnqualified convId of
+        (Conv _) -> GroupIdGen 0
+        (SubConv _ _) -> gen
+   in groupIdToConv (convToGroupId convId gen) === Right (convId, gen')

services/galley/src/Galley/API/Internal.hs

@@ -486,5 +486,5 @@ iGetMLSClientListForConv ::
   ConvId ->
   Sem r ClientList
 iGetMLSClientListForConv lusr cnv = do
-  cm <- E.lookupMLSClients (convToGroupId (Conv <$> tUntagged (qualifyAs lusr cnv)))
+  cm <- E.lookupMLSClients (convToGroupId' (Conv <$> tUntagged (qualifyAs lusr cnv)))
   pure $ ClientList (concatMap (Map.keys . snd) (Map.assocs cm))

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

@@ -127,7 +127,7 @@ getLocalSubConversation qusr lconv sconv = do
 
       -- deriving this detemernistically to prevent race condition between
       -- multiple threads creating the subconversation
-      let groupId = convToGroupId $ flip SubConv sconv <$> tUntagged lconv
+      let groupId = convToGroupId' $ flip SubConv sconv <$> tUntagged lconv
           epoch = Epoch 0
           suite = cnvmlsCipherSuite mlsMeta
       Eff.createSubConversation (tUnqualified lconv) sconv suite epoch groupId Nothing
@@ -293,7 +293,8 @@ deleteLocalSubConversation qusr lcnvId scnvId dsc = do
     unless (dscEpoch dsc == epoch) $ throwS @'MLSStaleMessage
     Eff.removeAllMLSClients gid
 
-    let newGid = convToGroupId (flip SubConv scnvId <$> tUntagged lcnvId)
+    -- TODO(SB) swallowing the error and starting with GroupIdGen 0 if nextGenGroupId
+    let newGid = fromRight (convToGroupId' (flip SubConv scnvId <$> tUntagged lcnvId)) $ nextGenGroupId gid
 
     -- the following overwrites any prior information about the subconversation
     Eff.createSubConversation cnvId scnvId cs (Epoch 0) newGid Nothing

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

@@ -126,4 +126,4 @@ withCommitLock lConvOrSubId gid epoch action =
     ttl = fromIntegral (600 :: Int) -- 10 minutes
 
 getConvFromGroupId :: Member (Error MLSProtocolError) r => GroupId -> Sem r (Qualified ConvOrSubConvId)
-getConvFromGroupId = either (throw . mlsProtocolError . T.pack) pure . groupIdToConv
+getConvFromGroupId = either (throw . mlsProtocolError . T.pack) (pure . fst) . groupIdToConv

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

@@ -74,7 +74,7 @@ createMLSSelfConversation lusr = do
             ncProtocol = ProtocolCreateMLSTag
           }
       meta = ncMetadata nc
-      gid = convToGroupId . fmap Conv . tUntagged . qualifyAs lusr $ cnv
+      gid = convToGroupId' . fmap Conv . tUntagged . qualifyAs lusr $ cnv
       -- FUTUREWORK: Stop hard-coding the cipher suite
       --
       -- 'CipherSuite 1' corresponds to
@@ -123,7 +123,7 @@ createConversation lcnv nc = do
       (proto, mgid, mep, mcs) = case ncProtocol nc of
         ProtocolCreateProteusTag -> (ProtocolProteus, Nothing, Nothing, Nothing)
         ProtocolCreateMLSTag ->
-          let gid = convToGroupId $ Conv <$> tUntagged lcnv
+          let gid = convToGroupId' $ Conv <$> tUntagged lcnv
               ep = Epoch 0
               cs = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519
            in ( ProtocolMLS
@@ -415,7 +415,7 @@ updateToMixedProtocol ::
   CipherSuiteTag ->
   Sem r ()
 updateToMixedProtocol lcnv cs = do
-  let gid = convToGroupId $ Conv <$> tUntagged lcnv
+  let gid = convToGroupId' $ Conv <$> tUntagged lcnv
       epoch = Epoch 0
   embedClient . retry x5 . batch $ do
     setType BatchLogged

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

@@ -2779,6 +2779,12 @@ testLastLeaverSubConv = do
 
     let subId = SubConvId "conference"
     qsub <- createSubConv qcnv alice1 subId
+    prePsc <-
+      liftTest $
+        responseJsonError
+          =<< getSubConv (qUnqualified alice) qcnv subId
+            <!! do
+              const 200 === statusCode
     void $ leaveCurrentConv alice1 qsub
 
     psc <-
@@ -2790,6 +2796,7 @@ testLastLeaverSubConv = do
     liftIO $ do
       pscEpoch psc @?= Epoch 0
       pscEpochTimestamp psc @?= Nothing
+      assertBool "group ID unchanged" $ pscGroupId prePsc /= pscGroupId psc
       length (pscMembers psc) @?= 0
 
 testLeaveSubConv :: Bool -> TestM ()

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

@@ -76,7 +76,7 @@ import Wire.API.Federation.API.Galley
 import Wire.API.MLS.CipherSuite
 import Wire.API.MLS.CommitBundle
 import Wire.API.MLS.Credential
-import Wire.API.MLS.Group.Serialisation (convToGroupId)
+import Wire.API.MLS.Group.Serialisation
 import Wire.API.MLS.KeyPackage
 import Wire.API.MLS.Keys
 import Wire.API.MLS.LeafNode
@@ -521,7 +521,7 @@ setupFakeMLSGroup ::
   MLSTest (GroupId, Qualified ConvId)
 setupFakeMLSGroup creator mSubId = do
   qcnv <- randomQualifiedId (ciDomain creator)
-  let groupId = convToGroupId $ maybe (Conv <$> qcnv) ((<$> qcnv) . flip SubConv) mSubId
+  let groupId = convToGroupId' $ maybe (Conv <$> qcnv) ((<$> qcnv) . flip SubConv) mSubId
   createGroup creator (fmap Conv qcnv) groupId
   pure (groupId, qcnv)