[FS-1335] Remove clients from subconversations when user is removed from main conversation

changelog.d/2-features/reflect-user-removal-from-parent-in-sub

@@ -0,0 +1 @@
+Removing or kicking a user from a conversation also removes the user's clients from any subconversation.

libs/wire-api/src/Wire/API/Conversation.hs

@@ -47,6 +47,9 @@ module Wire.API.Conversation
     GroupId (..),
     mlsSelfConvId,
 
+    -- * List of MLS client ids
+    ClientList (..),
+
     -- * Conversation properties
     Access (..),
     AccessRole (..),
@@ -232,6 +235,19 @@ instance ToSchema (Versioned 'V2 ConversationMetadata) where
           "ConversationMetadata"
           (conversationMetadataObjectSchema accessRolesSchemaV2)
 
+-- | Client list for internal API.
+data ClientList = ClientList {clClients :: [ClientId]}
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via (GenericUniform ClientList)
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema ClientList
+
+instance ToSchema ClientList where
+  schema =
+    object "ClientList" $
+      ClientList
+        <$> clClients
+          .= field "client_ids" (array schema)
+
 -- | Public-facing conversation type. Represents information that a
 -- particular user is allowed to see.
 --

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

@@ -130,20 +130,35 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con
   HasConversationActionEffects 'ConversationLeaveTag r =
     ( Members
         '[ MemberStore,
+           ProposalStore,
+           SubConversationStore,
            Error InternalError,
            Error NoChanges,
            ExternalAccess,
            FederatorAccess,
            GundeckAccess,
            Input UTCTime,
            Input Env,
-           ProposalStore,
            TinyLog
          ]
         r
     )
   HasConversationActionEffects 'ConversationRemoveMembersTag r =
-    (Members '[MemberStore, Error NoChanges] r)
+    ( Members
+        '[ MemberStore,
+           SubConversationStore,
+           ProposalStore,
+           Input Env,
+           Input UTCTime,
+           ExternalAccess,
+           FederatorAccess,
+           GundeckAccess,
+           Error InternalError,
+           Error NoChanges,
+           TinyLog
+         ]
+        r
+    )
   HasConversationActionEffects 'ConversationMemberUpdateTag r =
     (Members '[MemberStore, ErrorS 'ConvMemberNotFound] r)
   HasConversationActionEffects 'ConversationDeleteTag r =
@@ -292,6 +307,9 @@ type family PerformActionCalls tag where
   PerformActionCalls 'ConversationLeaveTag =
     ( CallsFed 'Galley "on-mls-message-sent"
     )
+  PerformActionCalls 'ConversationRemoveMembersTag =
+    ( CallsFed 'Galley "on-mls-message-sent"
+    )
   PerformActionCalls tag = ()
 
 -- | Returns additional members that resulted from the action (e.g. ConversationJoin)
@@ -314,31 +332,16 @@ performAction tag origUser lconv action = do
       performConversationJoin origUser lconv action
     SConversationLeaveTag -> do
       let victims = [origUser]
-      E.deleteMembers (tUnqualified lcnv) (toUserList lconv victims)
-      -- update in-memory view of the conversation
-      let lconv' =
-            lconv <&> \c ->
-              foldQualified
-                lconv
-                ( \lu ->
-                    c
-                      { convLocalMembers =
-                          filter (\lm -> lmId lm /= tUnqualified lu) (convLocalMembers c)
-                      }
-                )
-                ( \ru ->
-                    c
-                      { convRemoteMembers =
-                          filter (\rm -> rmId rm /= ru) (convRemoteMembers c)
-                      }
-                )
-                origUser
+      lconv' <- traverse (convDeleteMembers (toUserList lconv victims)) lconv
+      -- send remove proposals in the MLS case
       traverse_ (removeUser lconv') victims
       pure (mempty, action)
     SConversationRemoveMembersTag -> do
       let presentVictims = filter (isConvMemberL lconv) (toList action)
       when (null presentVictims) noChanges
-      E.deleteMembers (tUnqualified lcnv) (toUserList lconv presentVictims)
+      traverse_ (convDeleteMembers (toUserList lconv presentVictims)) lconv
+      -- send remove proposals in the MLS case
+      traverse_ (removeUser lconv) presentVictims
       pure (mempty, action) -- FUTUREWORK: should we return the filtered action here?
     SConversationMemberUpdateTag -> do
       void $ ensureOtherMember lconv (cmuTarget action) conv
@@ -453,6 +456,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do
            Input UTCTime,
            LegalHoldStore,
            MemberStore,
+           SubConversationStore,
            ProposalStore,
            SubConversationStore,
            TeamStore,

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

@@ -104,7 +104,8 @@ rmClientH ::
          MemberStore,
          Error InternalError,
          ProposalStore,
-         P.TinyLog
+         P.TinyLog,
+         SubConversationStore
        ]
       r,
     CallsFed 'Galley "on-client-removed",

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

@@ -143,6 +143,7 @@ onClientRemoved ::
          Input UTCTime,
          MemberStore,
          ProposalStore,
+         SubConversationStore,
          TinyLog
        ]
       r,

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

@@ -28,6 +28,7 @@ import Control.Exception.Safe (catchAny)
 import Control.Lens hiding (Getter, Setter, (.=))
 import Data.Id as Id
 import Data.List1 (maybeList1)
+import qualified Data.Map as Map
 import Data.Qualified
 import Data.Range
 import Data.Singletons
@@ -60,6 +61,7 @@ import Galley.Effects.FederatorAccess
 import Galley.Effects.GundeckAccess
 import Galley.Effects.LegalHoldStore as LegalHoldStore
 import Galley.Effects.MemberStore
+import qualified Galley.Effects.MemberStore as E
 import Galley.Effects.TeamStore
 import qualified Galley.Intra.Push as Intra
 import Galley.Monad
@@ -86,7 +88,7 @@ import qualified Servant hiding (WithStatus)
 import System.Logger.Class hiding (Path, name)
 import qualified System.Logger.Class as Log
 import Wire.API.ApplyMods
-import Wire.API.Conversation hiding (Member)
+import Wire.API.Conversation
 import Wire.API.Conversation.Action
 import Wire.API.Conversation.Role
 import Wire.API.CustomBackend
@@ -96,6 +98,7 @@ import Wire.API.Event.Conversation
 import Wire.API.Federation.API
 import Wire.API.Federation.API.Galley
 import Wire.API.Federation.Error
+import Wire.API.MLS.Group
 import Wire.API.Provider.Service hiding (Service)
 import Wire.API.Routes.API
 import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti
@@ -271,6 +274,19 @@ type InternalAPIBase =
                :> ReqBody '[Servant.JSON] Connect
                :> ConversationVerb
            )
+    -- This endpoint is meant for testing membership of a conversation
+    :<|> Named
+           "get-conversation-clients"
+           ( Summary "Get mls conversation client list"
+               :> ZLocalUser
+               :> CanThrow 'ConvNotFound
+               :> "conversation"
+               :> Capture "cnv" ConvId
+               :> MultiVerb1
+                    'GET
+                    '[Servant.JSON]
+                    (Respond 200 "Clients" ClientList)
+           )
     :<|> Named
            "guard-legalhold-policy-conflicts"
            ( "guard-legalhold-policy-conflicts"
@@ -479,6 +495,7 @@ internalAPI =
     mkNamedAPI @"status" (pure ())
       <@> mkNamedAPI @"delete-user" (callsFed rmUser)
       <@> mkNamedAPI @"connect" (callsFed Create.createConnectConversation)
+      <@> mkNamedAPI @"get-conversation-clients" iGetMLSClientListForConv
       <@> mkNamedAPI @"guard-legalhold-policy-conflicts" guardLegalholdPolicyConflictsH
       <@> legalholdWhitelistedTeamsAPI
       <@> iTeamsAPI
@@ -688,6 +705,7 @@ rmUser ::
          MemberStore,
          ProposalStore,
          P.TinyLog,
+         SubConversationStore,
          TeamStore
        ]
       r,
@@ -842,3 +860,18 @@ guardLegalholdPolicyConflictsH ::
 guardLegalholdPolicyConflictsH glh = do
   mapError @LegalholdConflicts (const $ Tagged @'MissingLegalholdConsent ()) $
     guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh)
+
+-- | Get an MLS conversation client list
+iGetMLSClientListForConv ::
+  forall r.
+  Members
+    '[ MemberStore,
+       ErrorS 'ConvNotFound
+     ]
+    r =>
+  Local UserId ->
+  ConvId ->
+  Sem r ClientList
+iGetMLSClientListForConv lusr cnv = do
+  cm <- E.lookupMLSClients (convToGroupId (qualifyAs lusr cnv))
+  pure $ ClientList (concatMap (Map.keys . snd) (Map.assocs cm))

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

@@ -653,6 +653,7 @@ data ProposalAction = ProposalAction
     -- to know if a commit has one when processing external commits
     paExternalInit :: Any
   }
+  deriving (Show)
 
 instance Semigroup ProposalAction where
   ProposalAction add1 rem1 init1 <> ProposalAction add2 rem2 init2 =
@@ -770,70 +771,72 @@ processExternalCommit ::
   ProposalAction ->
   Maybe UpdatePath ->
   Sem r ()
-processExternalCommit qusr mSenderClient lConvOrSub epoch action updatePath = withCommitLock (cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub) epoch $ do
-  let convOrSub = tUnqualified lConvOrSub
-  newKeyPackage <-
-    upLeaf
-      <$> note
-        (mlsProtocolError "External commits need an update path")
-        updatePath
-  when (paExternalInit action == mempty) $
-    throw . mlsProtocolError $
-      "The external commit is missing an external init proposal"
-  unless (paAdd action == mempty) $
-    throw . mlsProtocolError $
-      "The external commit must not have add proposals"
-
-  newRef <-
-    kpRef' newKeyPackage
-      & note (mlsProtocolError "An invalid key package in the update path")
-
-  -- validate and update mapping in brig
-  eithCid <-
-    nkpresClientIdentity
-      <$$> validateAndAddKeyPackageRef
-        NewKeyPackage
-          { nkpConversation = tUntagged (convOfConvOrSub . idForConvOrSub <$> lConvOrSub),
-            nkpKeyPackage = KeyPackageData (rmRaw newKeyPackage)
-          }
-  cid <- either (\errMsg -> throw (mlsProtocolError ("Tried to add invalid KeyPackage: " <> errMsg))) pure eithCid
-
-  unless (cidQualifiedUser cid == qusr) $
-    throw . mlsProtocolError $
-      "The external commit attempts to add another user"
-
-  senderClient <- noteS @'MLSMissingSenderClient mSenderClient
-
-  unless (ciClient cid == senderClient) $
-    throw . mlsProtocolError $
-      "The external commit attempts to add another client of the user, it must only add itself"
-
-  -- 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 <-
-    if Map.null (paRemove action)
-      then pure Nothing
-      else do
-        (remCid, r) <- derefUser (paRemove action) qusr
-        unless (cidQualifiedUser cid == cidQualifiedUser remCid)
-          . throw
-          . mlsProtocolError
-          $ "The external commit attempts to remove a client from a user other than themselves"
-        pure (Just r)
-
-  updateKeyPackageMapping lConvOrSub qusr (ciClient cid) remRef newRef
-
-  -- increment epoch number
-  lConvOrSub' <- for lConvOrSub incrementEpoch
-
-  -- fetch backend remove proposals of the previous epoch
-  kpRefs <- getPendingBackendRemoveProposals (cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub') epoch
-  -- requeue backend remove proposals for the current epoch
-  createAndSendRemoveProposals lConvOrSub' kpRefs qusr
+processExternalCommit qusr mSenderClient lConvOrSub epoch action updatePath =
+  withCommitLock (cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub) epoch $ do
+    let convOrSub = tUnqualified lConvOrSub
+    newKeyPackage <-
+      upLeaf
+        <$> note
+          (mlsProtocolError "External commits need an update path")
+          updatePath
+    when (paExternalInit action == mempty) $
+      throw . mlsProtocolError $
+        "The external commit is missing an external init proposal"
+    unless (paAdd action == mempty) $
+      throw . mlsProtocolError $
+        "The external commit must not have add proposals"
+
+    newRef <-
+      kpRef' newKeyPackage
+        & note (mlsProtocolError "An invalid key package in the update path")
+
+    -- validate and update mapping in brig
+    eithCid <-
+      nkpresClientIdentity
+        <$$> validateAndAddKeyPackageRef
+          NewKeyPackage
+            { nkpConversation = tUntagged (convOfConvOrSub . idForConvOrSub <$> lConvOrSub),
+              nkpKeyPackage = KeyPackageData (rmRaw newKeyPackage)
+            }
+    cid <- either (\errMsg -> throw (mlsProtocolError ("Tried to add invalid KeyPackage: " <> errMsg))) pure eithCid
+
+    unless (cidQualifiedUser cid == qusr) $
+      throw . mlsProtocolError $
+        "The external commit attempts to add another user"
+
+    senderClient <- noteS @'MLSMissingSenderClient mSenderClient
+
+    unless (ciClient cid == senderClient) $
+      throw . mlsProtocolError $
+        "The external commit attempts to add another client of the user, it must only add itself"
+
+    -- 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 <-
+      if Map.null (paRemove action)
+        then pure Nothing
+        else do
+          (remCid, r) <- derefUser (paRemove action) qusr
+          unless (cidQualifiedUser cid == cidQualifiedUser remCid)
+            . throw
+            . mlsProtocolError
+            $ "The external commit attempts to remove a client from a user other than themselves"
+          pure (Just r)
+
+    updateKeyPackageMapping lConvOrSub qusr (ciClient cid) remRef newRef
+
+    -- increment epoch number
+    lConvOrSub' <- for lConvOrSub incrementEpoch
+
+    -- fetch backend remove proposals of the previous epoch
+    kpRefs <- getPendingBackendRemoveProposals (cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub') epoch
+
+    -- requeue backend remove proposals for the current epoch
+    createAndSendRemoveProposals lConvOrSub' kpRefs qusr
   where
     derefUser :: ClientMap -> Qualified UserId -> Sem r (ClientIdentity, KeyPackageRef)
     derefUser cm user = case Map.assocs cm of
@@ -1394,6 +1397,7 @@ executeProposalAction qusr con lconvOrSub action = do
       Sem r (Maybe (Qualified UserId))
     checkRemoval cm qtarget clients = do
       let clientsInConv = Map.keysSet (Map.findWithDefault mempty qtarget cm)
+      -- TODO: skip the next check for subconversations
       when (clients /= clientsInConv) $ do
         -- FUTUREWORK: turn this error into a proper response
         throwS @'MLSClientMismatch