Restore previous behaviour of kicking

After #2667, when users are kicked out of a conversation, the events
being sent out would look like normal leave events. This commit restores
the previous behaviour: the events reflect the fact that the user was
kicked out, with the originating user set to the user who caused the
change that required users to be removed.

Author: pcapriotti

changelog.d/1-api-changes/backend-removal-fix

@@ -0,0 +1 @@
+Users being kicked out results in member-leave events originating from the user who caused the change in the conversation

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

@@ -340,7 +340,7 @@ performAction tag origUser lconv action = do
       E.setConversationReceiptMode (tUnqualified lcnv) (cruReceiptMode action)
       pure (mempty, action)
     SConversationAccessDataTag -> do
-      (bm, act) <- performConversationAccessData lconv action
+      (bm, act) <- performConversationAccessData origUser lconv action
       pure (bm, act)
 
 performConversationJoin ::
@@ -457,14 +457,11 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do
           then do
             for_ convUsersLHStatus $ \(mem, status) ->
               when (consentGiven status == ConsentNotGiven) $ do
-                let lvictim = qualifyAs lconv (lmId mem)
-                void . runError @NoChanges $
-                  updateLocalConversation
-                    @'ConversationLeaveTag
-                    (fmap convId lconv)
-                    (qUntagged lvictim)
-                    Nothing
-                    ()
+                kickMember
+                  qusr
+                  lconv
+                  (convBotsAndMembers (tUnqualified lconv))
+                  (qUntagged (qualifyAs lconv (lmId mem)))
           else throwS @'MissingLegalholdConsent
 
     checkLHPolicyConflictsRemote ::
@@ -474,10 +471,11 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do
 
 performConversationAccessData ::
   (HasConversationActionEffects 'ConversationAccessDataTag r) =>
+  Qualified UserId ->
   Local Conversation ->
   ConversationAccessData ->
   Sem r (BotsAndMembers, ConversationAccessData)
-performConversationAccessData lconv action = do
+performConversationAccessData qusr lconv action = do
   when (convAccessData conv == action) noChanges
   -- Remove conversation codes if CodeAccess is revoked
   when
@@ -506,16 +504,8 @@ performConversationAccessData lconv action = do
     let bmToNotify = current {bmBots = bmBots desired}
 
     -- Remove users and notify everyone
-    for_ (bmQualifiedMembers lcnv toRemove) $ \userToRemove -> do
-      (extraTargets, action') <- performAction SConversationLeaveTag userToRemove lconv ()
-      notifyConversationAction
-        (sing @'ConversationLeaveTag)
-        userToRemove
-        True
-        Nothing
-        lconv
-        (bmToNotify <> extraTargets)
-        action'
+    for_ (bmQualifiedMembers lcnv toRemove) $
+      kickMember qusr lconv bmToNotify
 
   pure (mempty, action)
   where
@@ -792,3 +782,40 @@ notifyRemoteConversationAction loc rconvUpdate con = do
   let bots = []
 
   pushConversationEvent con event localPresentUsers bots $> event
+
+-- | Kick a user from a conversation and send notifications.
+--
+-- This function removes the given victim from the conversation by making them
+-- leave, but then sends notifications as if the user was removed by someone
+-- else.
+kickMember ::
+  ( Member (Error InternalError) r,
+    Member ExternalAccess r,
+    Member FederatorAccess r,
+    Member GundeckAccess r,
+    Member ProposalStore r,
+    Member (Input UTCTime) r,
+    Member (Input Env) r,
+    Member MemberStore r,
+    Member TinyLog r
+  ) =>
+  Qualified UserId ->
+  Local Conversation ->
+  BotsAndMembers ->
+  Qualified UserId ->
+  Sem r ()
+kickMember qusr lconv targets victim = void . runError @NoChanges $ do
+  (extraTargets, _) <-
+    performAction
+      SConversationLeaveTag
+      victim
+      lconv
+      ()
+  notifyConversationAction
+    (sing @'ConversationRemoveMembersTag)
+    qusr
+    True
+    Nothing
+    lconv
+    (targets <> extraTargets)
+    (pure victim)

services/galley/test/integration/API.hs

@@ -1483,9 +1483,9 @@ postConvertTeamConv = do
     -- non-team members get kicked out
     liftIO $ do
       WS.assertMatchN_ (5 # Second) [wsA, wsB, wsE, wsM] $
-        wsAssertMemberLeave qconv qeve (pure qeve)
+        wsAssertMemberLeave qconv qalice (pure qeve)
       WS.assertMatchN_ (5 # Second) [wsA, wsB, wsE, wsM] $
-        wsAssertMemberLeave qconv qmallory (pure qmallory)
+        wsAssertMemberLeave qconv qalice (pure qmallory)
     -- joining (for mallory) is no longer possible
     postJoinCodeConv mallory j !!! const 403 === statusCode
     -- team members (dave) can still join
@@ -1537,14 +1537,17 @@ testAccessUpdateGuestRemoved = do
       -- note that removing users happens asynchronously, so this check should
       -- happen while the mock federator is still available
       WS.assertMatchN_ (5 # Second) [wsA, wsB, wsC] $
-        wsAssertMembersLeave (cnvQualifiedId conv) charlie [charlie]
+        wsAssertMembersLeave (cnvQualifiedId conv) alice [charlie]
       WS.assertMatchN_ (5 # Second) [wsA, wsB, wsC] $
-        wsAssertMembersLeave (cnvQualifiedId conv) dee [dee]
+        wsAssertMembersLeave (cnvQualifiedId conv) alice [dee]
 
     -- dee's remote receives a notification
+    let compareLists [] ys = [] @?= ys
+        compareLists (x : xs) ys = case break (== x) ys of
+          (ys1, _ : ys2) -> compareLists xs (ys1 <> ys2)
+          _ -> assertFailure $ "Could not find " <> show x <> " in " <> show ys
     liftIO $
-      sortOn
-        (fmap fst)
+      compareLists
         ( map
             ( \fr -> do
                 cu <- eitherDecode (frBody fr)
@@ -1558,20 +1561,18 @@ testAccessUpdateGuestRemoved = do
                 reqs
             )
         )
-        @?= sortOn
-          (fmap fst)
-          [ Right (charlie, SomeConversationAction (sing @'ConversationLeaveTag) ()),
-            Right (dee, SomeConversationAction (sing @'ConversationLeaveTag) ()),
-            Right
-              ( alice,
-                SomeConversationAction
-                  (sing @'ConversationAccessDataTag)
-                  ConversationAccessData
-                    { cupAccess = mempty,
-                      cupAccessRoles = Set.fromList [TeamMemberAccessRole]
-                    }
-              )
-          ]
+        [ Right (alice, SomeConversationAction (sing @'ConversationRemoveMembersTag) (pure charlie)),
+          Right (alice, SomeConversationAction (sing @'ConversationRemoveMembersTag) (pure dee)),
+          Right
+            ( alice,
+              SomeConversationAction
+                (sing @'ConversationAccessDataTag)
+                ConversationAccessData
+                  { cupAccess = mempty,
+                    cupAccessRoles = Set.fromList [TeamMemberAccessRole]
+                  }
+            )
+        ]
 
   -- only alice and bob remain
   conv2 <-