WPB-6258 Connection request from deleted user

changelog.d/3-bug-fixes/WPB-6258

@@ -0,0 +1 @@
+Send connection cancelled event to local pending connection when user gets deleted

integration/test/Notifications.hs

@@ -113,6 +113,12 @@ isConvDeleteNotif n = fieldEquals n "payload.0.type" "conversation.delete"
 isTeamMemberLeaveNotif :: MakesValue a => a -> App Bool
 isTeamMemberLeaveNotif n = nPayload n %. "type" `isEqual` "team.member-leave"
 
+isConnectionNotif :: MakesValue a => String -> a -> App Bool
+isConnectionNotif status n =
+  (&&)
+    <$> nPayload n %. "type" `isEqual` "user.connection"
+    <*> nPayload n %. "connection.status" `isEqual` status
+
 assertLeaveNotification ::
   ( HasCallStack,
     MakesValue fromUser,

integration/test/Test/Connection.hs

@@ -19,6 +19,7 @@ module Test.Connection where
 import API.Brig (getConnection, postConnection, putConnection)
 import API.BrigInternal
 import API.Galley
+import Notifications
 import SetupHelpers
 import Testlib.Prelude
 import UnliftIO.Async (forConcurrently_)
@@ -401,3 +402,14 @@ testFederationAllowMixedConnectWithRemote =
     connectTwoUsers alice bob
   where
     defSearchPolicy = "full_search"
+
+testPendingConnectionUserDeleted :: HasCallStack => App ()
+testPendingConnectionUserDeleted = do
+  alice <- randomUser OwnDomain def
+  bob <- randomUser OwnDomain def
+
+  withWebSockets [bob] $ \[bobWs] -> do
+    void $ postConnection alice bob >>= getBody 201
+    void $ awaitMatch (isConnectionNotif "pending") bobWs
+    void $ deleteUser alice
+    void $ awaitMatch (isConnectionNotif "cancelled") bobWs

services/brig/src/Brig/API/Connection.hs

@@ -121,7 +121,7 @@ createConnectionToLocalUser self conn target = do
         ConnectionUpdated o2s' (ucStatus <$> o2s)
           <$> wrapClient (Data.lookupName (tUnqualified self))
       let e2s = ConnectionUpdated s2o' (ucStatus <$> s2o) Nothing
-      mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s]
+      mapM_ (wrapHttp . Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s]
       pure s2o'
 
     update :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection)
@@ -158,7 +158,7 @@ createConnectionToLocalUser self conn target = do
           ConnectionUpdated o2s' (Just $ ucStatus o2s)
             <$> Data.lookupName (tUnqualified self)
       let e2s = ConnectionUpdated s2o' (Just $ ucStatus s2o) Nothing
-      lift $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s]
+      lift $ mapM_ (wrapHttp . Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s]
       pure $ Existed s2o'
 
     resend :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection)
@@ -281,7 +281,7 @@ updateConnectionToLocalUser self other newStatus conn = do
   let s2oUserConn = s2o'
   lift . for_ s2oUserConn $ \c ->
     let e2s = ConnectionUpdated c (Just $ ucStatus s2o) Nothing
-     in Intra.onConnectionEvent (tUnqualified self) conn e2s
+     in wrapHttp $ Intra.onConnectionEvent (tUnqualified self) conn e2s
   pure s2oUserConn
   where
     accept :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (Maybe UserConnection)
@@ -304,7 +304,7 @@ updateConnectionToLocalUser self other newStatus conn = do
         e2o <-
           ConnectionUpdated o2s' (Just $ ucStatus o2s)
             <$> wrapClient (Data.lookupName (tUnqualified self))
-        Intra.onConnectionEvent (tUnqualified self) conn e2o
+        wrapHttp $ Intra.onConnectionEvent (tUnqualified self) conn e2o
       lift . wrapClient $ Just <$> Data.updateConnection s2o AcceptedWithHistory
 
     block :: UserConnection -> ExceptT ConnectionError (AppT r) (Maybe UserConnection)
@@ -335,7 +335,7 @@ updateConnectionToLocalUser self other newStatus conn = do
             ConnectionUpdated o2s' (Just $ ucStatus o2s)
               <$> Data.lookupName (tUnqualified self)
         -- TODO: is this correct? shouldnt o2s be sent to other?
-        Intra.onConnectionEvent (tUnqualified self) conn e2o
+        wrapHttp $ Intra.onConnectionEvent (tUnqualified self) conn e2o
       lift . wrapClient $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new)
 
     cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (Maybe UserConnection)
@@ -347,7 +347,7 @@ updateConnectionToLocalUser self other newStatus conn = do
       lift $ traverse_ (wrapHttp . Intra.blockConv lfrom conn) (ucConvId s2o)
       o2s' <- lift . wrapClient $ Data.updateConnection o2s CancelledWithHistory
       let e2o = ConnectionUpdated o2s' (Just $ ucStatus o2s) Nothing
-      lift $ Intra.onConnectionEvent (tUnqualified self) conn e2o
+      lift $ wrapHttp $ Intra.onConnectionEvent (tUnqualified self) conn e2o
       change s2o Cancelled
 
     change :: UserConnection -> Relation -> ExceptT ConnectionError (AppT r) (Maybe UserConnection)
@@ -414,7 +414,7 @@ updateConnectionInternal = \case
           traverse_ (wrapHttp . Intra.blockConv lfrom Nothing) (ucConvId uconn)
           uconn' <- wrapClient $ Data.updateConnection uconn (mkRelationWithHistory (ucStatus uconn) MissingLegalholdConsent)
           let ev = ConnectionUpdated uconn' (Just $ ucStatus uconn) Nothing
-          Intra.onConnectionEvent (tUnqualified self) Nothing ev
+          wrapHttp $ Intra.onConnectionEvent (tUnqualified self) Nothing ev
 
     removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError (AppT r) ()
     removeLHBlocksInvolving self =
@@ -456,7 +456,7 @@ updateConnectionInternal = \case
                     ucPrev = Just $ ucStatus uconnRev,
                     ucName = connName
                   }
-          lift $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent
+          lift $ wrapHttp $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent
 
     relationWithHistory ::
       Local UserId ->

services/brig/src/Brig/API/Connection/Remote.hs

@@ -188,7 +188,7 @@ transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do
 pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> (AppT r) ()
 pushEvent self mzcon connection = do
   let event = ConnectionUpdated connection Nothing Nothing
-  Intra.onConnectionEvent (tUnqualified self) mzcon event
+  wrapHttp $ Intra.onConnectionEvent (tUnqualified self) mzcon event
 
 performLocalAction ::
   Local UserId ->

services/brig/src/Brig/Data/Connection.hs

@@ -44,7 +44,6 @@ module Brig.Data.Connection
     remoteConnectionDelete,
     remoteConnectionSelectFromDomain,
     remoteConnectionClear,
-    remoteConnectionsSelectUsers,
 
     -- * Re-exports
     module T,

services/brig/src/Brig/IO/Intra.hs

@@ -54,7 +54,7 @@ import Brig.API.Error (internalServerError)
 import Brig.API.Types
 import Brig.API.Util
 import Brig.App
-import Brig.Data.Connection (lookupContactList)
+import Brig.Data.Connection (resultList)
 import Brig.Data.Connection qualified as Data
 import Brig.Federation.Client (notifyUserDeleted)
 import Brig.IO.Journal qualified as Journal
@@ -77,13 +77,14 @@ import Data.ByteString.Conversion
 import Data.ByteString.Lazy qualified as BL
 import Data.Conduit.List qualified as C
 import Data.Id
-import Data.Json.Util ((#))
+import Data.Json.Util (toUTCTimeMillis, (#))
 import Data.List.Split (chunksOf)
 import Data.List1 (List1, list1, singleton)
 import Data.Proxy
 import Data.Qualified
 import Data.Range
 import Data.Set qualified as Set
+import Data.Time.Clock (getCurrentTime)
 import GHC.TypeLits
 import Gundeck.Types.Push.V2
 import Gundeck.Types.Push.V2 qualified as Push
@@ -128,22 +129,28 @@ onUserEvent orig conn e =
     *> journalEvent orig e
 
 onConnectionEvent ::
+  ( Log.MonadLogger m,
+    MonadReader Env m,
+    MonadMask m,
+    MonadHttp m,
+    HasRequestId m,
+    MonadUnliftIO m
+  ) =>
   -- | Originator of the event.
   UserId ->
   -- | Client connection ID, if any.
   Maybe ConnId ->
   -- | The event.
   ConnectionEvent ->
-  (AppT r) ()
+  m ()
 onConnectionEvent orig conn evt = do
   let from = ucFrom (ucConn evt)
-  wrapHttp $
-    notify
-      (singleton $ ConnectionEvent evt)
-      orig
-      Push.RouteAny
-      conn
-      (pure $ list1 from [])
+  notify
+    (singleton $ ConnectionEvent evt)
+    orig
+    Push.RouteAny
+    conn
+    (pure $ list1 from [])
 
 onPropertyEvent ::
   -- | Originator of the event.
@@ -275,6 +282,7 @@ dispatchNotifications orig conn e = case e of
     event = singleton $ UserEvent e
 
 notifyUserDeletionLocals ::
+  forall m.
   ( Log.MonadLogger m,
     MonadReader Env m,
     MonadMask m,
@@ -288,8 +296,44 @@ notifyUserDeletionLocals ::
   List1 Event ->
   m ()
 notifyUserDeletionLocals deleted conn event = do
-  recipients <- list1 deleted <$> lookupContactList deleted
-  notify event deleted Push.RouteDirect conn (pure recipients)
+  luid <- qualifyLocal deleted
+  connectionPages Nothing luid (toRange (Proxy @500))
+  where
+    handler :: [UserConnection] -> m ()
+    handler connections = do
+      -- sent event to connections that are accepted
+      case qUnqualified . ucTo <$> filter ((==) Accepted . ucStatus) connections of
+        x : xs -> notify event deleted Push.RouteDirect conn (pure (list1 x xs))
+        [] -> pure ()
+      -- also send a connection cancelled event to connections that are pending
+      d <- viewFederationDomain
+      forM_
+        (filter ((==) Sent . ucStatus) connections)
+        ( \uc -> do
+            now <- liftIO $ toUTCTimeMillis <$> getCurrentTime
+            -- because the connections are going to be removed from the database anyway when a user gets deleted
+            -- we don't need to save the updated connection state in the database
+            -- note that we switch from and to users so that the "other" user becomes the recipient of the event
+            let ucCancelled =
+                  UserConnection
+                    (qUnqualified (ucTo uc))
+                    (Qualified (ucFrom uc) d)
+                    Cancelled
+                    now
+                    (ucConvId uc)
+            let e = ConnectionUpdated ucCancelled Nothing Nothing
+            onConnectionEvent deleted conn e
+        )
+
+    connectionPages :: Maybe UserId -> Local UserId -> Range 1 500 Int32 -> m ()
+    connectionPages mbStart user pageSize = do
+      page <- Data.lookupLocalConnections user mbStart pageSize
+      case resultList page of
+        [] -> pure ()
+        xs -> do
+          handler xs
+          when (Data.resultHasMore page) $
+            connectionPages (Just (maximum (qUnqualified . ucTo <$> xs))) user pageSize
 
 notifyUserDeletionRemotes ::
   forall m.
@@ -485,7 +529,7 @@ notifyContacts events orig route conn = do
     list1 orig <$> liftA2 (++) contacts teamContacts
   where
     contacts :: m [UserId]
-    contacts = lookupContactList orig
+    contacts = Data.lookupContactList orig
 
     teamContacts :: m [UserId]
     teamContacts = screenMemberList <$> getTeamContacts orig