Deleting clients creates MLS remove proposals

changelog.d/2-features/mls-remote-proposals-on-client-deletion

@@ -0,0 +1 @@
+Deleting clients creates MLS remove proposals

libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs

@@ -69,6 +69,16 @@ type GalleyApi =
     :<|> FedEndpoint "mls-welcome" MLSWelcomeRequest EmptyResponse
     :<|> FedEndpoint "on-mls-message-sent" RemoteMLSMessage EmptyResponse
     :<|> FedEndpoint "send-mls-message" MessageSendRequest MLSMessageResponse
+    :<|> FedEndpoint "on-client-removed" ClientRemovedRequest EmptyResponse
+
+data ClientRemovedRequest = ClientRemovedRequest
+  { crrUser :: UserId,
+    crrClient :: ClientId,
+    crrConvs :: [ConvId]
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via (GenericUniform ClientRemovedRequest)
+  deriving (FromJSON, ToJSON) via (CustomEncoded ClientRemovedRequest)
 
 data GetConversationsRequest = GetConversationsRequest
   { gcrUserId :: UserId,

services/galley/galley.cabal

@@ -206,6 +206,7 @@ library
     , extra                      >=1.3
     , galley-types               >=0.65.0
     , gundeck-types              >=1.35.2
+    , hex
     , HsOpenSSL                  >=0.11
     , HsOpenSSL-x509-system      >=0.1
     , http-client                >=0.4

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

@@ -22,16 +22,40 @@ module Galley.API.Clients
   )
 where
 
+import Data.Hex
 import Data.Id
+import Data.Proxy
+import Data.Qualified
+import Data.Range
+import Data.String.Conversions
+import qualified Data.Text as T
+import Data.Time
+import Galley.API.Error
+import Galley.API.MLS.Removal
+import qualified Galley.API.Query as Query
+import Galley.API.Util
 import Galley.Effects
 import qualified Galley.Effects.BrigAccess as E
 import qualified Galley.Effects.ClientStore as E
+import Galley.Effects.ConversationStore (getConversation)
+import Galley.Effects.FederatorAccess
+import Galley.Effects.ProposalStore (ProposalStore)
+import Galley.Env
 import Galley.Types.Clients (clientIds, fromUserClients)
 import Imports
 import Network.Wai
 import Network.Wai.Predicate hiding (setStatus)
 import Network.Wai.Utilities
 import Polysemy
+import qualified Polysemy.Error as Poly
+import Polysemy.Input
+import qualified Polysemy.TinyLog as P
+import qualified System.Logger as Log
+import Wire.API.Conversation hiding (Member)
+import Wire.API.Federation.API
+import Wire.API.Federation.API.Galley (ClientRemovedRequest (ClientRemovedRequest))
+import Wire.API.Routes.MultiTablePaging
+import Wire.Sem.Paging.Cassandra (CassandraPaging)
 
 getClientsH ::
   Members '[BrigAccess, ClientStore] r =>
@@ -61,9 +85,71 @@ addClientH (usr ::: clt) = do
   pure empty
 
 rmClientH ::
-  Member ClientStore r =>
+  forall p1 r.
+  ( p1 ~ CassandraPaging,
+    Members
+      '[ ClientStore,
+         ConversationStore,
+         ExternalAccess,
+         FederatorAccess,
+         GundeckAccess,
+         Input Env,
+         Input (Local ()),
+         Input UTCTime,
+         ListItems p1 ConvId,
+         ListItems p1 (Remote ConvId),
+         MemberStore,
+         Poly.Error InternalError,
+         ProposalStore,
+         P.TinyLog
+       ]
+      r
+  ) =>
   UserId ::: ClientId ->
   Sem r Response
-rmClientH (usr ::: clt) = do
-  E.deleteClient usr clt
+rmClientH (usr ::: cid) = do
+  lusr <- qualifyLocal usr
+  let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32
+  firstConvIds <- Query.conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000)
+  goConvs nRange1000 firstConvIds lusr
+
+  E.deleteClient usr cid
   pure empty
+  where
+    rpc = fedClient @'Galley @"on-client-removed"
+    goConvs :: Range 1 1000 Int32 -> ConvIdsPage -> Local UserId -> Sem r ()
+    goConvs range page lusr = do
+      loc :: Local () <- input
+      let (localConvs, remoteConvs) = partitionQualified loc (mtpResults page)
+      for_ localConvs $ \convId -> do
+        mConv <- getConversation convId
+        for_ mConv $ \conv -> do
+          lconv <- qualifyLocal conv
+          removeClient lconv (qUntagged lusr) cid
+      traverse_ removeRemoteMLSClients (rangedChunks remoteConvs)
+      when (mtpHasMore page) $ do
+        let nextState = mtpPagingState page
+            nextQuery = GetPaginatedConversationIds (Just nextState) range
+        newCids <- Query.conversationIdsPageFrom lusr nextQuery
+        goConvs range newCids lusr
+
+    removeRemoteMLSClients :: Range 1 1000 [Remote ConvId] -> Sem r ()
+    removeRemoteMLSClients cids = do
+      for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do
+        runFederatedEither remoteConvs (rpc (ClientRemovedRequest usr cid (tUnqualified remoteConvs)))
+          >>= logAndIgnoreError "Error in onConversationUpdated call" usr
+
+    logAndIgnoreError message usr' res = do
+      case res of
+        Left federationError ->
+          P.err
+            ( Log.msg
+                ( "Federation error while notifying remote backends of a client deletion (Galley). "
+                    <> message
+                    <> " "
+                    <> show federationError
+                )
+                . Log.field "user" (show usr')
+                . Log.field "client" (hex . T.unpack . client $ cid)
+            )
+        Right _ -> pure ()

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

@@ -50,6 +50,7 @@ import Galley.App
 import qualified Galley.Data.Conversation as Data
 import Galley.Effects
 import qualified Galley.Effects.BrigAccess as E
+import Galley.Effects.ConversationStore (getConversation)
 import qualified Galley.Effects.ConversationStore as E
 import qualified Galley.Effects.FireAndForget as E
 import qualified Galley.Effects.MemberStore as E
@@ -79,7 +80,7 @@ import Wire.API.Error.Galley
 import Wire.API.Event.Conversation
 import Wire.API.Federation.API
 import Wire.API.Federation.API.Common (EmptyResponse (..))
-import Wire.API.Federation.API.Galley (ConversationUpdateResponse)
+import Wire.API.Federation.API.Galley (ClientRemovedRequest, ConversationUpdateResponse)
 import qualified Wire.API.Federation.API.Galley as F
 import Wire.API.Federation.Error
 import Wire.API.MLS.Credential
@@ -108,6 +109,35 @@ federationSitemap =
     :<|> Named @"mls-welcome" mlsSendWelcome
     :<|> Named @"on-mls-message-sent" onMLSMessageSent
     :<|> Named @"send-mls-message" sendMLSMessage
+    :<|> Named @"on-client-removed" onClientRemoved
+
+onClientRemoved ::
+  ( Members
+      '[ ConversationStore,
+         Error InternalError,
+         ExternalAccess,
+         FederatorAccess,
+         GundeckAccess,
+         Input Env,
+         Input (Local ()),
+         Input UTCTime,
+         MemberStore,
+         ProposalStore,
+         TinyLog
+       ]
+      r
+  ) =>
+  Domain ->
+  ClientRemovedRequest ->
+  Sem r EmptyResponse
+onClientRemoved domain req = do
+  let qusr = Qualified (F.crrUser req) domain
+  for_ (F.crrConvs req) $ \convId -> do
+    mConv <- getConversation convId
+    for mConv $ \conv -> do
+      lconv <- qualifyLocal conv
+      removeClient lconv qusr (F.crrClient req)
+  pure EmptyResponse
 
 onConversationCreated ::
   Members

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

@@ -16,7 +16,9 @@
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
 module Galley.API.MLS.Removal
-  ( removeUserWithClientMap,
+  ( removeClientsWithClientMap,
+    removeClient,
+    removeUserWithClientMap,
     removeUser,
   )
 where
@@ -26,6 +28,7 @@ import Control.Lens (view)
 import Data.Id
 import qualified Data.Map as Map
 import Data.Qualified
+import qualified Data.Set as Set
 import Data.Time
 import Galley.API.Error
 import Galley.API.MLS.Propagate
@@ -42,12 +45,14 @@ import Polysemy.Input
 import Polysemy.TinyLog
 import Wire.API.Conversation.Protocol
 import Wire.API.MLS.Credential
+import Wire.API.MLS.KeyPackage
 import Wire.API.MLS.Keys
 import Wire.API.MLS.Message
 import Wire.API.MLS.Proposal
 import Wire.API.MLS.Serialisation
 
-removeUserWithClientMap ::
+-- | Send remove proposals for a set of clients to clients in the ClientMap.
+removeClientsWithClientMap ::
   ( Members
       '[ Input UTCTime,
          TinyLog,
@@ -61,16 +66,17 @@ removeUserWithClientMap ::
       r
   ) =>
   Local Data.Conversation ->
+  Set (ClientId, KeyPackageRef) ->
   ClientMap ->
   Qualified UserId ->
   Sem r ()
-removeUserWithClientMap lc cm qusr = do
+removeClientsWithClientMap lc cs cm qusr = do
   case Data.convProtocol (tUnqualified lc) of
     ProtocolProteus -> pure ()
     ProtocolMLS meta -> do
       keyPair <- mlsKeyPair_ed25519 <$> (inputs (view mlsKeys) <*> pure RemovalPurpose)
       (secKey, pubKey) <- note (InternalErrorWithDescription "backend removal key missing") $ keyPair
-      for_ (Map.findWithDefault mempty qusr cm) $ \(_client, kpref) -> do
+      for_ cs $ \(_client, kpref) -> do
         let proposal = mkRemoveProposal kpref
             msg = mkSignedMessage secKey pubKey (cnvmlsGroupId meta) (cnvmlsEpoch meta) (ProposalMessage proposal)
             msgEncoded = encodeMLS' msg
@@ -81,6 +87,54 @@ removeUserWithClientMap lc cm qusr = do
           proposal
         propagateMessage qusr lc cm Nothing msgEncoded
 
+-- | Send remove proposals for a single client of a user to the local conversation.
+removeClient ::
+  ( Members
+      '[ Error InternalError,
+         ExternalAccess,
+         FederatorAccess,
+         GundeckAccess,
+         Input Env,
+         Input UTCTime,
+         MemberStore,
+         ProposalStore,
+         TinyLog
+       ]
+      r
+  ) =>
+  Local Data.Conversation ->
+  Qualified UserId ->
+  ClientId ->
+  Sem r ()
+removeClient lc qusr cid = do
+  cm <- lookupMLSClients (fmap Data.convId lc)
+  let cidAndKP = Set.filter ((==) cid . fst) $ Map.findWithDefault mempty qusr cm
+  removeClientsWithClientMap lc cidAndKP cm qusr
+
+-- | Send remove proposals for all clients of the user to clients in the ClientMap.
+--
+-- All clients of the user have to be contained in the ClientMap.
+removeUserWithClientMap ::
+  ( Members
+      '[ Input UTCTime,
+         TinyLog,
+         ExternalAccess,
+         FederatorAccess,
+         GundeckAccess,
+         Error InternalError,
+         ProposalStore,
+         Input Env
+       ]
+      r
+  ) =>
+  Local Data.Conversation ->
+  ClientMap ->
+  Qualified UserId ->
+  Sem r ()
+removeUserWithClientMap lc cm qusr =
+  removeClientsWithClientMap lc (Map.findWithDefault mempty qusr cm) cm qusr
+
+-- | Send remove proposals for all clients of the user to the local conversation.
 removeUser ::
   ( Members
       '[ Error InternalError,