Support deleting conversations with federated users

changelog.d/6-federation/delete-conversations

@@ -0,0 +1 @@
+Support deleting conversations with federated users

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

@@ -44,6 +44,7 @@ data ConversationAction
   | ConversationActionReceiptModeUpdate ConversationReceiptModeUpdate
   | ConversationActionMemberUpdate (Qualified UserId) OtherMemberUpdate
   | ConversationActionAccessUpdate ConversationAccessData
+  | ConversationActionDelete
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform ConversationAction)
   deriving (ToJSON, FromJSON) via (CustomEncoded ConversationAction)
@@ -71,6 +72,8 @@ conversationActionToEvent now quid qcnv (ConversationActionMemberUpdate target (
    in Event MemberStateUpdate qcnv quid now (EdMemberUpdate update)
 conversationActionToEvent now quid qcnv (ConversationActionAccessUpdate update) =
   Event ConvAccessUpdate qcnv quid now (EdConvAccessUpdate update)
+conversationActionToEvent now quid qcnv ConversationActionDelete =
+  Event ConvDelete qcnv quid now EdConvDelete
 
 conversationActionTag :: Qualified UserId -> ConversationAction -> Action
 conversationActionTag _ (ConversationActionAddMembers _ _) = AddConversationMember
@@ -82,3 +85,4 @@ conversationActionTag _ (ConversationActionMessageTimerUpdate _) = ModifyConvers
 conversationActionTag _ (ConversationActionReceiptModeUpdate _) = ModifyConversationReceiptMode
 conversationActionTag _ (ConversationActionMemberUpdate _ _) = ModifyOtherConversationMember
 conversationActionTag _ (ConversationActionAccessUpdate _) = ModifyConversationAccess
+conversationActionTag _ ConversationActionDelete = DeleteConversation

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

@@ -163,6 +163,9 @@ onConversationUpdated requestingDomain cu = do
     ConversationActionMemberUpdate _ _ -> pure (Just $ cuAction cu, [])
     ConversationActionReceiptModeUpdate _ -> pure (Just $ cuAction cu, [])
     ConversationActionAccessUpdate _ -> pure (Just $ cuAction cu, [])
+    ConversationActionDelete -> do
+      Data.removeLocalMembersFromRemoteConv rconvId presentUsers
+      pure (Just $ cuAction cu, [])
 
   unless allUsersArePresent $
     Log.warn $

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

@@ -82,14 +82,14 @@ import qualified Data.UUID.Util as UUID
 import Galley.API.Error as Galley
 import Galley.API.LegalHold
 import qualified Galley.API.Teams.Notifications as APITeamQueue
+import qualified Galley.API.Update as API
 import Galley.API.Util
 import Galley.App
 import qualified Galley.Data as Data
 import qualified Galley.Data.LegalHold as Data
 import qualified Galley.Data.SearchVisibility as SearchVisibilityData
 import Galley.Data.Services (BotMember)
 import qualified Galley.Data.TeamFeatures as TeamFeatures
-import qualified Galley.Data.Types as Data
 import qualified Galley.External as External
 import qualified Galley.Intra.Journal as Journal
 import Galley.Intra.Push
@@ -762,22 +762,10 @@ getTeamConversation zusr tid cid = do
   Data.teamConversation tid cid >>= maybe (throwErrorDescriptionType @ConvNotFound) pure
 
 deleteTeamConversation :: UserId -> ConnId -> TeamId -> ConvId -> Galley ()
-deleteTeamConversation zusr zcon tid cid = do
-  localDomain <- viewFederationDomain
-  let qconvId = Qualified cid localDomain
-      qusr = Qualified zusr localDomain
-  (bots, cmems) <- localBotsAndUsers <$> Data.members cid
-  ensureActionAllowed Roles.DeleteConversation =<< getSelfMemberFromLocalsLegacy zusr cmems
-  flip Data.deleteCode Data.ReusableCode =<< Data.mkKey cid
-  now <- liftIO getCurrentTime
-  let ce = Conv.Event Conv.ConvDelete qconvId qusr now Conv.EdConvDelete
-  let recps = fmap recipient cmems
-  let convPush = newPushLocal ListComplete zusr (ConvEvent ce) recps <&> pushConn .~ Just zcon
-  pushSome $ maybeToList convPush
-  void . forkIO $ void $ External.deliver (bots `zip` repeat ce)
-  -- TODO: we don't delete bots here, but we should do that, since every
-  -- bot user can only be in a single conversation
-  Data.removeTeamConv tid cid
+deleteTeamConversation zusr zcon _tid cid = do
+  lusr <- qualifyLocal zusr
+  lconv <- qualifyLocal cid
+  void $ API.deleteLocalConversation lusr zcon lconv
 
 getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley Response
 getSearchVisibilityH (uid ::: tid ::: _) = do

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

@@ -36,6 +36,7 @@ module Galley.API.Update
     updateLocalConversation,
     updateConversationAccessUnqualified,
     updateConversationAccess,
+    deleteLocalConversation,
 
     -- * Managing Members
     addMembersUnqualified,
@@ -368,6 +369,15 @@ updateLocalConversationMessageTimer lusr con lcnv update =
     updateLocalConversation lcnv (qUntagged lusr) (Just con) $
       ConversationActionMessageTimerUpdate update
 
+deleteLocalConversation ::
+  Local UserId ->
+  ConnId ->
+  Local ConvId ->
+  Galley (UpdateResult Event)
+deleteLocalConversation lusr con lcnv =
+  getUpdateResult $
+    updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationActionDelete
+
 -- | Update a local conversation, and notify all local and remote members.
 updateLocalConversation ::
   Local ConvId ->
@@ -435,6 +445,13 @@ performAction qusr conv action = case action of
   ConversationActionAccessUpdate update -> do
     performAccessUpdateAction qusr conv update
     pure (mempty, action)
+  ConversationActionDelete -> lift $ do
+    let cid = Data.convId conv
+    (`Data.deleteCode` ReusableCode) =<< mkKey cid
+    case Data.convTeam conv of
+      Nothing -> Data.deleteConversation cid
+      Just tid -> Data.removeTeamConv tid cid
+    pure (mempty, action)
 
 addCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response
 addCodeH (usr ::: zcon ::: cnv) =

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

@@ -65,7 +65,7 @@ import Wire.API.ErrorDescription
 import qualified Wire.API.Federation.API.Brig as FederatedBrig
 import Wire.API.Federation.API.Galley as FederatedGalley
 import Wire.API.Federation.Client (FederationClientFailure, FederatorClient, executeFederated)
-import Wire.API.Federation.Error (federationErrorToWai)
+import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented)
 import Wire.API.Federation.GRPC.Types (Component (..))
 import qualified Wire.API.User as User
 
@@ -162,6 +162,19 @@ ensureConversationActionAllowed action conv self = do
   -- extra action-specific checks
   case action of
     ConversationActionAddMembers _ role -> ensureConvRoleNotElevated self role
+    ConversationActionDelete -> do
+      case Data.convTeam conv of
+        Just tid -> do
+          foldQualified
+            loc
+            ( \lusr -> do
+                void $
+                  Data.teamMember tid (tUnqualified lusr)
+                    >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember)
+            )
+            (\_ -> throwM federationNotImplemented)
+            (convMemberId loc self)
+        Nothing -> pure ()
     ConversationActionAccessUpdate target -> do
       -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and
       -- so on; users are not supposed to be able to make other conversations

services/galley/src/Galley/Data.hs

@@ -137,7 +137,7 @@ import Data.Id as Id
 import Data.Json.Util (UTCTimeMillis (..))
 import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus)
 import qualified Data.List.Extra as List
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
 import Data.List.Split (chunksOf)
 import qualified Data.Map.Strict as Map
 import Data.Misc (Milliseconds)
@@ -762,8 +762,15 @@ updateConversationMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessa
 deleteConversation :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> m ()
 deleteConversation cid = do
   retry x5 $ write Cql.markConvDeleted (params Quorum (Identity cid))
-  mm <- members cid
-  for_ mm $ \m -> removeMember (lmId m) cid
+
+  localMembers <- members cid
+  for_ (nonEmpty localMembers) $ \ms ->
+    removeLocalMembersFromLocalConv cid (lmId <$> ms)
+
+  remoteMembers <- lookupRemoteMembers cid
+  for_ (nonEmpty remoteMembers) $ \ms ->
+    removeRemoteMembersFromLocalConv cid (rmId <$> ms)
+
   retry x5 $ write Cql.deleteConv (params Quorum (Identity cid))
 
 acceptConnect :: MonadClient m => ConvId -> m ()

services/galley/test/integration/API.hs

@@ -87,7 +87,9 @@ import Wire.API.Conversation
 import Wire.API.Conversation.Action
 import qualified Wire.API.Federation.API.Brig as FederatedBrig
 import Wire.API.Federation.API.Galley
-  ( GetConversationsResponse (..),
+  ( Api (onConversationUpdated),
+    ConversationUpdate (cuAction, cuAlreadyPresentUsers, cuOrigUserId),
+    GetConversationsResponse (..),
     RemoteConvMembers (..),
     RemoteConversation (..),
   )
@@ -163,6 +165,7 @@ tests s =
           test s "fail to add members when not connected" postMembersFail,
           test s "fail to add too many members" postTooManyMembersFail,
           test s "add remote members" testAddRemoteMember,
+          test s "delete conversation with remote members" testDeleteTeamConversationWithRemoteMembers,
           test s "get conversations/:domain/:cnv - local" testGetQualifiedLocalConv,
           test s "get conversations/:domain/:cnv - local, not found" testGetQualifiedLocalConvNotFound,
           test s "get conversations/:domain/:cnv - local, not participating" testGetQualifiedLocalConvNotParticipating,
@@ -1909,6 +1912,50 @@ testAddRemoteMember = do
         toJSON [mkProfile bob (Name "bob")]
       | otherwise = toJSON ()
 
+testDeleteTeamConversationWithRemoteMembers :: TestM ()
+testDeleteTeamConversationWithRemoteMembers = do
+  (alice, tid) <- createBindingTeam
+  localDomain <- viewFederationDomain
+  let qalice = Qualified alice localDomain
+
+  bobId <- randomId
+  let remoteDomain = Domain "far-away.example.com"
+      remoteBob = Qualified bobId remoteDomain
+
+  convId <- decodeConvId <$> postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing
+  let _qconvId = Qualified convId localDomain
+
+  connectWithRemoteUser alice remoteBob
+
+  let brigApi = emptyFederatedBrig
+      galleyApi =
+        emptyFederatedGalley
+          { onConversationUpdated = \_domain _update -> pure ()
+          }
+
+  (_, received) <- withTempServantMockFederator brigApi galleyApi localDomain $ do
+    postQualifiedMembers alice (remoteBob :| []) convId
+      !!! const 200 === statusCode
+
+    deleteTeamConv tid convId alice
+      !!! const 200 === statusCode
+
+  liftIO $ do
+    let convUpdates = mapMaybe parseFedRequest received
+    convUpdate <- case (filter ((== ConversationActionDelete) . cuAction) convUpdates) of
+      [] -> assertFailure "No ConversationUpdate requests received"
+      [convDelete] -> pure convDelete
+      _ -> assertFailure "Multiple ConversationUpdate requests received"
+    cuAlreadyPresentUsers convUpdate @?= [bobId]
+    cuOrigUserId convUpdate @?= qalice
+  where
+    parseFedRequest :: FromJSON a => F.FederatedRequest -> Maybe a
+    parseFedRequest fr =
+      case F.request fr of
+        Just r ->
+          (decode . cs) (F.body r)
+        Nothing -> Nothing
+
 testGetQualifiedLocalConv :: TestM ()
 testGetQualifiedLocalConv = do
   alice <- randomUser

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

@@ -75,6 +75,7 @@ tests s =
       test s "POST /federation/on-conversation-updated : Notify local user about member update" notifyMemberUpdate,
       test s "POST /federation/on-conversation-updated : Notify local user about receipt mode update" notifyReceiptMode,
       test s "POST /federation/on-conversation-updated : Notify local user about access update" notifyAccess,
+      test s "POST /federation/on-conversation-updated : Notify local users about a deleted conversation" notifyDeletedConversation,
       test s "POST /federation/leave-conversation : Success" leaveConversationSuccess,
       test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent,
       test s "POST /federation/send-message : Post a message sent from another backend" sendMessage
@@ -488,6 +489,54 @@ notifyMemberUpdate = do
     MemberStateUpdate
     (EdMemberUpdate d)
 
+notifyDeletedConversation :: TestM ()
+notifyDeletedConversation = do
+  c <- view tsCannon
+
+  qalice <- randomQualifiedUser
+  let alice = qUnqualified qalice
+
+  bob <- randomId
+  conv <- randomId
+  let bobDomain = Domain "bob.example.com"
+      qbob = Qualified bob bobDomain
+      qconv = Qualified conv bobDomain
+      mkMember quid = OtherMember quid Nothing roleNameWireMember
+
+  mapM_ (`connectWithRemoteUser` qbob) [alice]
+  registerRemoteConv
+    qconv
+    bob
+    (Just "gossip")
+    (Set.fromList (map mkMember [qalice]))
+
+  fedGalleyClient <- view tsFedGalleyClient
+
+  do
+    aliceConvs <- listRemoteConvs bobDomain alice
+    liftIO $ aliceConvs @?= [qconv]
+
+  WS.bracketR c alice $ \wsAlice -> do
+    now <- liftIO getCurrentTime
+    let cu =
+          FedGalley.ConversationUpdate
+            { FedGalley.cuTime = now,
+              FedGalley.cuOrigUserId = qbob,
+              FedGalley.cuConvId = qUnqualified qconv,
+              FedGalley.cuAlreadyPresentUsers = [alice],
+              FedGalley.cuAction = ConversationActionDelete
+            }
+    FedGalley.onConversationUpdated fedGalleyClient bobDomain cu
+
+    liftIO $ do
+      WS.assertMatch_ (5 # Second) wsAlice $ \n -> do
+        let e = List1.head (WS.unpackPayload n)
+        ConvDelete @=? evtType e
+
+  do
+    aliceConvs <- listRemoteConvs bobDomain alice
+    liftIO $ aliceConvs @?= []
+
 -- TODO: test adding non-existing users
 -- TODO: test adding resulting in an empty notification
 

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

@@ -1161,7 +1161,6 @@ testDeleteBindingTeam ownerHasPassword = do
 testDeleteTeamConv :: TestM ()
 testDeleteTeamConv = do
   localDomain <- viewFederationDomain
-  g <- view tsGalley
   c <- view tsCannon
   owner <- Util.randomUser
   let p = Util.symmPermissions [DoNotUseDeprecatedDeleteConversation]
@@ -1179,14 +1178,9 @@ testDeleteTeamConv = do
   for_ [owner, member ^. userId, extern] $ \u -> Util.assertConvMember u cid1
   for_ [owner, member ^. userId] $ \u -> Util.assertConvMember u cid2
   WS.bracketR3 c owner extern (member ^. userId) $ \(wsOwner, wsExtern, wsMember) -> do
-    delete
-      ( g
-          . paths ["teams", toByteString' tid, "conversations", toByteString' cid2]
-          . zUser (member ^. userId)
-          . zConn "conn"
-      )
-      !!! const 200
-      === statusCode
+    deleteTeamConv tid cid2 (member ^. userId)
+      !!! const 200 === statusCode
+
     -- We no longer send duplicate conv deletion events
     -- i.e., as both a regular "conversation.delete" to all
     -- conversation members and as "team.conversation-delete"
@@ -1195,14 +1189,9 @@ testDeleteTeamConv = do
     checkConvDeleteEvent qcid2 wsOwner
     checkConvDeleteEvent qcid2 wsMember
     WS.assertNoEvent timeout [wsOwner, wsMember]
-    delete
-      ( g
-          . paths ["teams", toByteString' tid, "conversations", toByteString' cid1]
-          . zUser (member ^. userId)
-          . zConn "conn"
-      )
-      !!! const 200
-      === statusCode
+
+    deleteTeamConv tid cid1 (member ^. userId)
+      !!! const 200 === statusCode
     -- We no longer send duplicate conv deletion events
     -- i.e., as both a regular "conversation.delete" to all
     -- conversation members and as "team.conversation-delete"

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

@@ -587,6 +587,16 @@ postTeamConv tid u us name a r mtimer = do
   let conv = NewConvUnmanaged $ NewConv us [] name (Set.fromList a) r (Just (ConvTeamInfo tid False)) mtimer Nothing roleNameWireAdmin
   post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv
 
+deleteTeamConv :: (HasGalley m, MonadIO m, MonadHttp m) => TeamId -> ConvId -> UserId -> m ResponseLBS
+deleteTeamConv tid convId zusr = do
+  g <- viewGalley
+  delete
+    ( g
+        . paths ["teams", toByteString' tid, "conversations", toByteString' convId]
+        . zUser zusr
+        . zConn "conn"
+    )
+
 postConvWithRole :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> RoleName -> TestM ResponseLBS
 postConvWithRole u members name access arole timer role =
   postConvQualified