From dc9d79699bf1387b366535ad872a61f7fbbfe90b Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 31 Jan 2024 16:09:56 +0000 Subject: [PATCH 1/9] wip --- integration/test/Test/Connection.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/integration/test/Test/Connection.hs b/integration/test/Test/Connection.hs index 0852552c1d4..96fe4eb6640 100644 --- a/integration/test/Test/Connection.hs +++ b/integration/test/Test/Connection.hs @@ -401,3 +401,17 @@ testFederationAllowMixedConnectWithRemote = connectTwoUsers alice bob where defSearchPolicy = "full_search" + +-- TODO(leif): if there needs to be a change in backend behavior, this test can be the starting point +_testPendingConnectionUserDeleted :: HasCallStack => App () +_testPendingConnectionUserDeleted = do + alice <- randomUser OwnDomain def + bob <- randomUser OwnDomain def + + void $ postConnection alice bob >>= getBody 201 + + void $ deleteUser alice + + bindResponse (putConnection bob alice "ignored") \resp -> do + putStrLn $ "status: " <> show (resp.status) + putStrLn =<< prettyJSON (resp.json) From b42b07e1d9455c1da47cba947e6f690cd209a3a4 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 5 Feb 2024 14:22:47 +0000 Subject: [PATCH 2/9] impl conn cancelled event on local user deletion --- integration/test/Notifications.hs | 6 ++ integration/test/Test/Connection.hs | 18 +++-- services/brig/src/Brig/API/Connection.hs | 16 ++--- .../brig/src/Brig/API/Connection/Remote.hs | 2 +- services/brig/src/Brig/Data/Connection.hs | 1 - services/brig/src/Brig/IO/Intra.hs | 70 +++++++++++++++---- 6 files changed, 80 insertions(+), 33 deletions(-) diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index 9ea53706223..0fdd7df49a2 100644 --- a/integration/test/Notifications.hs +++ b/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, diff --git a/integration/test/Test/Connection.hs b/integration/test/Test/Connection.hs index 96fe4eb6640..a4a7663d737 100644 --- a/integration/test/Test/Connection.hs +++ b/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_) @@ -402,16 +403,13 @@ testFederationAllowMixedConnectWithRemote = where defSearchPolicy = "full_search" --- TODO(leif): if there needs to be a change in backend behavior, this test can be the starting point -_testPendingConnectionUserDeleted :: HasCallStack => App () -_testPendingConnectionUserDeleted = do +testPendingConnectionUserDeleted :: HasCallStack => App () +testPendingConnectionUserDeleted = do alice <- randomUser OwnDomain def bob <- randomUser OwnDomain def - void $ postConnection alice bob >>= getBody 201 - - void $ deleteUser alice - - bindResponse (putConnection bob alice "ignored") \resp -> do - putStrLn $ "status: " <> show (resp.status) - putStrLn =<< prettyJSON (resp.json) + withWebSockets [bob] $ \[bobWs] -> do + void $ postConnection alice bob >>= getBody 201 + void $ awaitMatch (isConnectionNotif "pending") bobWs + void $ deleteUser alice + void $ awaitMatch (isConnectionNotif "cancelled") bobWs diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 88484ca4480..299f5a6df76 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/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 -> diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 8d75155198a..91461f211ac 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/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 -> diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index 16031d654eb..e9ef5c45602 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -44,7 +44,6 @@ module Brig.Data.Connection remoteConnectionDelete, remoteConnectionSelectFromDomain, remoteConnectionClear, - remoteConnectionsSelectUsers, -- * Re-exports module T, diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 1735cd65d5c..96fba9dfbea 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/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 From e367b17a4268a6af13e50dc3c85ae71a49ddaa13 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 6 Feb 2024 09:07:22 +0000 Subject: [PATCH 3/9] changelog --- changelog.d/3-bug-fixes/WPB-6258 | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/3-bug-fixes/WPB-6258 diff --git a/changelog.d/3-bug-fixes/WPB-6258 b/changelog.d/3-bug-fixes/WPB-6258 new file mode 100644 index 00000000000..2513b3c396e --- /dev/null +++ b/changelog.d/3-bug-fixes/WPB-6258 @@ -0,0 +1 @@ +Send connection cancelled event to local pending connection when user gets deleted From 768e69fccee053f420baec8ab898457ecc7e49de Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 6 Feb 2024 11:27:40 +0000 Subject: [PATCH 4/9] wip --- integration/test/Test/Connection.hs | 6 +++--- libs/types-common/src/Data/Range.hs | 2 +- services/brig/src/Brig/Data/Connection.hs | 9 +++------ services/brig/src/Brig/IO/Intra.hs | 19 +++++++++++-------- 4 files changed, 18 insertions(+), 18 deletions(-) diff --git a/integration/test/Test/Connection.hs b/integration/test/Test/Connection.hs index a4a7663d737..97f77ece534 100644 --- a/integration/test/Test/Connection.hs +++ b/integration/test/Test/Connection.hs @@ -403,10 +403,10 @@ testFederationAllowMixedConnectWithRemote = where defSearchPolicy = "full_search" -testPendingConnectionUserDeleted :: HasCallStack => App () -testPendingConnectionUserDeleted = do +testPendingConnectionUserDeleted :: HasCallStack => Domain -> App () +testPendingConnectionUserDeleted domain = do alice <- randomUser OwnDomain def - bob <- randomUser OwnDomain def + bob <- randomUser domain def withWebSockets [bob] $ \[bobWs] -> do void $ postConnection alice bob >>= getBody 201 diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index 898df2142c1..b2e941b01e6 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/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 diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index e9ef5c45602..d8eda288bad 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -267,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] @@ -410,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 :: diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 96fba9dfbea..84b0213d3b2 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -56,7 +56,7 @@ import Brig.API.Util import Brig.App import Brig.Data.Connection (resultList) import Brig.Data.Connection qualified as Data -import Brig.Federation.Client (notifyUserDeleted) +import Brig.Federation.Client (notifyUserDeleted, sendConnectionAction) import Brig.IO.Journal qualified as Journal import Brig.RPC import Brig.Types.User.Event @@ -345,23 +345,26 @@ notifyUserDeletionRemotes :: UserId -> m () notifyUserDeletionRemotes deleted = do + luid <- qualifyLocal deleted runConduit $ - Data.lookupRemoteConnectedUsersC deleted (fromInteger (natVal (Proxy @UserDeletedNotificationMaxConnections))) + Data.lookupRemoteConnectedUsersC luid (fromInteger (natVal (Proxy @UserDeletedNotificationMaxConnections))) .| C.mapM_ fanoutNotifications where - fanoutNotifications :: [Remote UserId] -> m () + fanoutNotifications :: [Remote UserConnection] -> m () fanoutNotifications = mapM_ notifyBackend . bucketRemote - notifyBackend :: Remote [UserId] -> m () - notifyBackend uids = do - case tUnqualified (checked <$> uids) of + notifyBackend :: Remote [UserConnection] -> m () + notifyBackend ucs = do + case tUnqualified (checked <$> ucs) of Nothing -> -- The user IDs cannot be more than 1000, so we can assume the range -- check will only fail because there are 0 User Ids. pure () - Just rangedUids -> do + Just rangedUcs -> do luidDeleted <- qualifyLocal deleted - notifyUserDeleted luidDeleted (qualifyAs uids rangedUids) + notifyUserDeleted luidDeleted (qualifyAs ucs ((fmap (fmap (qUnqualified . ucTo))) rangedUcs)) + -- also sent connection cancelled events to the connections that are pending + sendConnectionAction luidDeleted Nothing (tUntagged <$> ucs) Cancelled !>> ConnectFederationError -- | Push events to other users. push :: From 834b76fe06ef9f66dd5e4526e6ff68e6f93844a5 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 7 Feb 2024 16:14:32 +0000 Subject: [PATCH 5/9] handle remote connections --- libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs | 4 ++++ libs/wire-api/src/Wire/API/Routes/Public/Brig.hs | 14 ++++++++++++++ services/brig/src/Brig/IO/Intra.hs | 10 +++++++++- 3 files changed, 27 insertions(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 4a52bf64aa7..7e9e76ff581 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/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,6 +681,7 @@ type AuthAPI = "legalhold-login" ( "legalhold-login" :> MakesFederatedCall 'Brig "on-user-deleted-connections" + :> MakesFederatedCall 'Brig "send-connection-action" :> ReqBody '[JSON] LegalHoldLogin :> MultiVerb1 'POST '[JSON] TokenResponse ) @@ -686,6 +689,7 @@ type AuthAPI = "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 diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index ada615249cb..15b07451e10 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/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, diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 84b0213d3b2..780845ee9a0 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -364,7 +364,15 @@ notifyUserDeletionRemotes deleted = do luidDeleted <- qualifyLocal deleted notifyUserDeleted luidDeleted (qualifyAs ucs ((fmap (fmap (qUnqualified . ucTo))) rangedUcs)) -- also sent connection cancelled events to the connections that are pending - sendConnectionAction luidDeleted Nothing (tUntagged <$> ucs) Cancelled !>> ConnectFederationError + let remotePendingConnections = qualifyAs ucs <$> filter ((==) Sent . ucStatus) (fromRange rangedUcs) + forM_ remotePendingConnections $ sendCancelledEvent luidDeleted + + sendCancelledEvent :: Local UserId -> Remote UserConnection -> m () + sendCancelledEvent luidDeleted ruc = do + result <- runExceptT $ sendConnectionAction luidDeleted Nothing (qUnqualified . ucTo <$> ruc) RemoteRescind + case result of + Left _ -> pure () -- TODO: handle error + Right _ -> pure () -- | Push events to other users. push :: From fd472f066102d6b4edcc78b28e2d68e100507bbc Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 8 Feb 2024 08:33:22 +0000 Subject: [PATCH 6/9] log errors --- services/brig/src/Brig/IO/Intra.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 780845ee9a0..0f39bffaa3f 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -369,9 +369,12 @@ notifyUserDeletionRemotes deleted = do sendCancelledEvent :: Local UserId -> Remote UserConnection -> m () sendCancelledEvent luidDeleted ruc = do - result <- runExceptT $ sendConnectionAction luidDeleted Nothing (qUnqualified . ucTo <$> ruc) RemoteRescind - case result of - Left _ -> pure () -- TODO: handle error + runExceptT (sendConnectionAction luidDeleted Nothing (qUnqualified . ucTo <$> ruc) RemoteRescind) >>= \case + -- I don't think we want to abort the operation since this is running asynchronously and cannot be retried anyway + Left e -> + Log.err $ + field "error" (show e) + . msg (val "An error occurred while sending a connection cancelled event to a remote backend.") Right _ -> pure () -- | Push events to other users. From 0e1ffa5566ac384a148150d1ee36f228ac4d48d8 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 8 Feb 2024 08:42:30 +0000 Subject: [PATCH 7/9] also send a notification to the deleted user themselves --- services/brig/src/Brig/IO/Intra.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 0f39bffaa3f..4439fc5ae08 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -297,6 +297,9 @@ notifyUserDeletionLocals :: m () notifyUserDeletionLocals deleted conn event = do luid <- qualifyLocal deleted + -- first we send a notification to the deleted user's devices + notify event deleted Push.RouteDirect conn (pure (list1 deleted [])) + -- then to all their connections connectionPages Nothing luid (toRange (Proxy @500)) where handler :: [UserConnection] -> m () From 5184b30e16a9723eead6be77e801fb33041aa78b Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 8 Feb 2024 10:22:12 +0000 Subject: [PATCH 8/9] hi ci From b5d1e8e77281f0566316fdacb2b36b23820bb27e Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 14 Feb 2024 11:15:39 +0000 Subject: [PATCH 9/9] renaming, changed comment --- integration/test/Test/Connection.hs | 4 ++-- services/brig/src/Brig/IO/Intra.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/integration/test/Test/Connection.hs b/integration/test/Test/Connection.hs index 97f77ece534..f982df677d4 100644 --- a/integration/test/Test/Connection.hs +++ b/integration/test/Test/Connection.hs @@ -404,9 +404,9 @@ testFederationAllowMixedConnectWithRemote = defSearchPolicy = "full_search" testPendingConnectionUserDeleted :: HasCallStack => Domain -> App () -testPendingConnectionUserDeleted domain = do +testPendingConnectionUserDeleted bobsDomain = do alice <- randomUser OwnDomain def - bob <- randomUser domain def + bob <- randomUser bobsDomain def withWebSockets [bob] $ \[bobWs] -> do void $ postConnection alice bob >>= getBody 201 diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 7b97b1b3eb8..f81fd20f7a7 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -350,7 +350,7 @@ notifyUserDeletionRemotes deleted = do sendCancelledEvent :: Local UserId -> Remote UserConnection -> Sem r () sendCancelledEvent luidDeleted ruc = do embed (runExceptT (sendConnectionAction luidDeleted Nothing (qUnqualified . ucTo <$> ruc) RemoteRescind)) >>= \case - -- I don't think we want to abort the operation since this is running asynchronously and cannot be retried anyway + -- should we abort the whole process if we fail to send the event to a remote backend? Left e -> Log.err $ field "error" (show e)