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 => Domain -> App ()
+testPendingConnectionUserDeleted domain = do
+  alice <- randomUser OwnDomain def
+  bob <- randomUser domain def
+
+  withWebSockets [bob] $ \[bobWs] -> do
+    void $ postConnection alice bob >>= getBody 201
+    void $ awaitMatch (isConnectionNotif "pending") bobWs
+    void $ deleteUser alice
+    void $ awaitMatch (isConnectionNotif "cancelled") bobWs

libs/types-common/src/Data/Range.hs

@@ -98,7 +98,7 @@ import Test.QuickCheck qualified as QC
 newtype Range (n :: Nat) (m :: Nat) a = Range
   { fromRange :: a
   }
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Functor)
 
 toRange :: (n <= x, x <= m, KnownNat x, Num a) => Proxy x -> Range n m a
 toRange = Range . fromIntegral . natVal

libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs

@@ -173,6 +173,7 @@ type AccountAPI =
     "createUserNoVerify"
     ( "users"
         :> MakesFederatedCall 'Brig "on-user-deleted-connections"
+        :> MakesFederatedCall 'Brig "send-connection-action"
         :> ReqBody '[Servant.JSON] NewUser
         :> MultiVerb 'POST '[Servant.JSON] RegisterInternalResponses (Either RegisterError SelfProfile)
     )
@@ -181,6 +182,7 @@ type AccountAPI =
            ( "users"
                :> "spar"
                :> MakesFederatedCall 'Brig "on-user-deleted-connections"
+               :> MakesFederatedCall 'Brig "send-connection-action"
                :> ReqBody '[Servant.JSON] NewUserSpar
                :> MultiVerb 'POST '[Servant.JSON] CreateUserSparInternalResponses (Either CreateUserSparError SelfProfile)
            )
@@ -679,13 +681,15 @@ type AuthAPI =
     "legalhold-login"
     ( "legalhold-login"
         :> MakesFederatedCall 'Brig "on-user-deleted-connections"
+        :> MakesFederatedCall 'Brig "send-connection-action"
         :> ReqBody '[JSON] LegalHoldLogin
         :> MultiVerb1 'POST '[JSON] TokenResponse
     )
     :<|> Named
            "sso-login"
            ( "sso-login"
                :> MakesFederatedCall 'Brig "on-user-deleted-connections"
+               :> MakesFederatedCall 'Brig "send-connection-action"
                :> ReqBody '[JSON] SsoLogin
                :> QueryParam' [Optional, Strict] "persist" Bool
                :> MultiVerb1 'POST '[JSON] TokenResponse

libs/wire-api/src/Wire/API/Routes/Public/Brig.hs

@@ -316,6 +316,7 @@ type SelfAPI =
                \password, it must be provided. if password is correct, or if neither \
                \a verified identity nor a password exists, account deletion \
                \is scheduled immediately."
+          :> MakesFederatedCall 'Brig "send-connection-action"
           :> CanThrow 'InvalidUser
           :> CanThrow 'InvalidCode
           :> CanThrow 'BadCredentials
@@ -333,6 +334,7 @@ type SelfAPI =
     Named
       "put-self"
       ( Summary "Update your profile."
+          :> MakesFederatedCall 'Brig "send-connection-action"
           :> ZUser
           :> ZConn
           :> "self"
@@ -358,6 +360,7 @@ type SelfAPI =
           :> Description
                "Your phone number can only be removed if you also have an \
                \email address and a password."
+          :> MakesFederatedCall 'Brig "send-connection-action"
           :> ZUser
           :> ZConn
           :> "self"
@@ -373,6 +376,7 @@ type SelfAPI =
           :> Description
                "Your email address can only be removed if you also have a \
                \phone number."
+          :> MakesFederatedCall 'Brig "send-connection-action"
           :> ZUser
           :> ZConn
           :> "self"
@@ -405,6 +409,7 @@ type SelfAPI =
     :<|> Named
            "change-locale"
            ( Summary "Change your locale."
+               :> MakesFederatedCall 'Brig "send-connection-action"
                :> ZUser
                :> ZConn
                :> "self"
@@ -415,6 +420,8 @@ type SelfAPI =
     :<|> Named
            "change-handle"
            ( Summary "Change your handle."
+               :> MakesFederatedCall 'Brig "send-connection-action"
+               :> MakesFederatedCall 'Brig "send-connection-action"
                :> ZUser
                :> ZConn
                :> "self"
@@ -477,6 +484,7 @@ type AccountAPI =
              "If the environment where the registration takes \
              \place is private and a registered email address or phone \
              \number is not whitelisted, a 403 error is returned."
+        :> MakesFederatedCall 'Brig "send-connection-action"
         :> "register"
         :> ReqBody '[JSON] NewUserPublic
         :> MultiVerb 'POST '[JSON] RegisterResponses (Either RegisterError RegisterSuccess)
@@ -487,6 +495,7 @@ type AccountAPI =
     :<|> Named
            "verify-delete"
            ( Summary "Verify account deletion with a code."
+               :> MakesFederatedCall 'Brig "send-connection-action"
                :> CanThrow 'InvalidCode
                :> "delete"
                :> ReqBody '[JSON] VerifyDeleteUser
@@ -498,6 +507,7 @@ type AccountAPI =
     :<|> Named
            "get-activate"
            ( Summary "Activate (i.e. confirm) an email address or phone number."
+               :> MakesFederatedCall 'Brig "send-connection-action"
                :> Description "See also 'POST /activate' which has a larger feature set."
                :> CanThrow 'UserKeyExists
                :> CanThrow 'InvalidActivationCodeWrongUser
@@ -524,6 +534,7 @@ type AccountAPI =
                :> Description
                     "Activation only succeeds once and the number of \
                     \failed attempts for a valid key is limited."
+               :> MakesFederatedCall 'Brig "send-connection-action"
                :> CanThrow 'UserKeyExists
                :> CanThrow 'InvalidActivationCodeWrongUser
                :> CanThrow 'InvalidActivationCodeWrongCode
@@ -728,6 +739,7 @@ type UserClientAPI =
   Named
     "add-client"
     ( Summary "Register a new client"
+        :> MakesFederatedCall 'Brig "send-connection-action"
         :> CanThrow 'TooManyClients
         :> CanThrow 'MissingAuth
         :> CanThrow 'MalformedPrekeys
@@ -1334,6 +1346,7 @@ type AuthAPI =
              \ Every other combination is invalid.\
              \ Access tokens can be given as query parameter or authorisation\
              \ header, with the latter being preferred."
+        :> MakesFederatedCall 'Brig "send-connection-action"
         :> QueryParam "client_id" ClientId
         :> Cookies '["zuid" ::: SomeUserToken]
         :> Bearer SomeAccessToken
@@ -1364,6 +1377,7 @@ type AuthAPI =
            ( "login"
                :> Summary "Authenticate a user to obtain a cookie and first access token"
                :> Description "Logins are throttled at the server's discretion"
+               :> MakesFederatedCall 'Brig "send-connection-action"
                :> ReqBody '[JSON] Login
                :> QueryParam'
                     [ Optional,

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,
@@ -268,10 +267,10 @@ lookupAllStatuses lfroms = do
       map (\(d, u, r) -> toConnectionStatusV2 from d u r)
         <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from)))
 
-lookupRemoteConnectedUsersC :: forall m. (MonadClient m) => UserId -> Int32 -> ConduitT () [Remote UserId] m ()
+lookupRemoteConnectedUsersC :: forall m. (MonadClient m) => Local UserId -> Int32 -> ConduitT () [Remote UserConnection] m ()
 lookupRemoteConnectedUsersC u maxResults =
-  paginateC remoteConnectionsSelectUsers (paramsP LocalQuorum (Identity u) maxResults) x1
-    .| C.map (map (uncurry toRemoteUnsafe))
+  paginateC remoteConnectionSelect (paramsP LocalQuorum (Identity (tUnqualified u)) maxResults) x1
+    .| C.map (\xs -> map (\x@(d, _, _, _, _, _) -> toRemoteUnsafe d (toRemoteUserConnection u x)) xs)
 
 -- | See 'lookupContactListWithRelation'.
 lookupContactList :: (MonadClient m) => UserId -> m [UserId]
@@ -411,9 +410,6 @@ remoteRelationsSelect = "SELECT right_user, status FROM connection_remote WHERE
 remoteRelationsSelectAll :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory)
 remoteRelationsSelectAll = "SELECT right_domain, right_user, status FROM connection_remote WHERE left = ?"
 
-remoteConnectionsSelectUsers :: PrepQuery R (Identity UserId) (Domain, UserId)
-remoteConnectionsSelectUsers = "SELECT right_domain, right_user FROM connection_remote WHERE left = ?"
-
 -- Conversions
 
 toLocalUserConnection ::