Do not fail user deletion when a remote notification fails

changelog.d/6-federation/dont-fail-user-deletion-unavailble-remotes

@@ -0,0 +1 @@
+Do not fail user deletion when a remote notification fails

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

@@ -93,6 +93,7 @@ import Data.Coerce (coerce)
 import qualified Data.Conduit.List as C
 import qualified Data.Currency as Currency
 import Data.Domain
+import Data.Either.Combinators (whenLeft)
 import qualified Data.HashMap.Strict as M
 import Data.Id
 import Data.Json.Util (UTCTimeMillis, (#))
@@ -118,7 +119,7 @@ import qualified Network.Wai.Utilities.Error as Wai
 import System.Logger.Class as Log hiding (name, (.=))
 import Wire.API.Federation.API.Brig
 import Wire.API.Federation.Client
-import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented)
+import Wire.API.Federation.Error (federationNotImplemented)
 import Wire.API.Message (UserClients)
 import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus)
 import Wire.API.Team.LegalHold (LegalholdProtectee)
@@ -275,13 +276,8 @@ notifyUserDeletionRemotes deleted = do
         Just rangedUids -> do
           luidDeleted <- qualifyLocal deleted
           eitherFErr <- runExceptT (notifyUserDeleted luidDeleted (qualifyAs uids rangedUids))
-          case eitherFErr of
-            Left fErr -> do
-              logFederationError (tDomain uids) fErr
-              -- FUTUTREWORK: Do something better here?
-              -- FUTUREWORK: Write test that this happens
-              throwM $ federationErrorToWai fErr
-            Right () -> pure ()
+          whenLeft eitherFErr $
+            logFederationError (tDomain uids)
 
     logFederationError :: Domain -> FederationError -> AppT IO ()
     logFederationError domain fErr =

services/brig/test/integration/API/User/Account.hs

@@ -136,6 +136,7 @@ tests _ at opts p b c ch g aws =
       test' aws p "delete /i/users/:uid - 202" $ testDeleteInternal b c aws,
       test' aws p "delete with profile pic" $ testDeleteWithProfilePic b ch,
       test' aws p "delete with connected remote users" $ testDeleteWithRemotes opts b,
+      test' aws p "delete with connected remote users and failed remote notifcations" $ testDeleteWithRemotesAndFailedNotifications opts b c,
       test' aws p "put /i/users/:uid/sso-id" $ testUpdateSSOId b g,
       testGroup
         "temporary customer extensions"
@@ -1224,7 +1225,7 @@ testDeleteWithRemotes opts brig = do
   sendConnectionAction brig opts (userId localUser) remote2UserBlocked (Just FedBrig.RemoteConnect) Accepted
   void $ putConnectionQualified brig (userId localUser) remote2UserBlocked Blocked
 
-  let fedMockResponse = OutwardResponseBody (cs $ Aeson.encode EmptyResponse)
+  let fedMockResponse = const (OutwardResponseBody (cs $ Aeson.encode EmptyResponse))
   let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response
       galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) =
         case (requestMethod, requestPath) of
@@ -1257,6 +1258,56 @@ testDeleteWithRemotes opts brig = do
           (eitherDecode . cs) (F.body r)
         Nothing -> Left "No request"
 
+testDeleteWithRemotesAndFailedNotifications :: Opt.Opts -> Brig -> Cannon -> Http ()
+testDeleteWithRemotesAndFailedNotifications opts brig cannon = do
+  alice <- randomUser brig
+  alex <- randomUser brig
+  let localDomain = qDomain (userQualifiedId alice)
+
+  let bDomain = Domain "b.example.com"
+      cDomain = Domain "c.example.com"
+  bob <- Qualified <$> randomId <*> pure bDomain
+  carl <- Qualified <$> randomId <*> pure cDomain
+
+  postConnection brig (userId alice) (userId alex) !!! const 201 === statusCode
+  putConnection brig (userId alex) (userId alice) Accepted !!! const 200 === statusCode
+  sendConnectionAction brig opts (userId alice) bob (Just FedBrig.RemoteConnect) Accepted
+  sendConnectionAction brig opts (userId alice) carl (Just FedBrig.RemoteConnect) Accepted
+
+  let fedMockResponse req =
+        if Domain (F.domain req) == bDomain
+          then F.OutwardResponseError (F.OutwardError F.ConnectionRefused "mocked connection problem with b domain")
+          else OutwardResponseBody (cs $ Aeson.encode EmptyResponse)
+
+  let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response
+      galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) =
+        case (Http.parseMethod requestMethod, requestPath) of
+          (Right Http.DELETE, ["i", "user"]) -> do
+            let response = Wai.responseLBS Http.status200 [(Http.hContentType, "application/json")] (cs $ Aeson.encode EmptyResponse)
+            pure response
+          _ -> error "not mocked"
+
+  (_, rpcCalls, _galleyCalls) <- WS.bracketR cannon (userId alex) $ \wsAlex -> do
+    let action = withMockedFederatorAndGalley opts localDomain fedMockResponse galleyHandler $ do
+          deleteUser (userId alice) (Just defPassword) brig !!! do
+            const 200 === statusCode
+    liftIO action <* do
+      void . liftIO . WS.assertMatch (5 # Second) wsAlex $ matchDeleteUserNotification (userQualifiedId alice)
+
+  liftIO $ do
+    rRpc <- assertOne $ filter (\c -> F.domain c == domainText cDomain) rpcCalls
+    cUdn <- assertRight $ parseFedRequest rRpc
+    udcnUser cUdn @?= userId alice
+    sort (fromRange (udcnConnections cUdn))
+      @?= sort (map qUnqualified [carl])
+  where
+    parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a
+    parseFedRequest fr =
+      case F.request fr of
+        Just r ->
+          (eitherDecode . cs) (F.body r)
+        Nothing -> Left "No request"
+
 testUpdateSSOId :: Brig -> Galley -> Http ()
 testUpdateSSOId brig galley = do
   noSuchUserId <- Id <$> liftIO UUID.nextRandom

services/brig/test/integration/Util.hs

@@ -89,7 +89,7 @@ import Wire.API.Conversation
 import Wire.API.Conversation.Role (roleNameWireAdmin)
 import qualified Wire.API.Federation.API.Brig as FedBrig
 import qualified Wire.API.Federation.API.Galley as FedGalley
-import Wire.API.Federation.GRPC.Types (OutwardResponse)
+import Wire.API.Federation.GRPC.Types (FederatedRequest, OutwardResponse)
 import qualified Wire.API.Federation.Mock as Mock
 import Wire.API.Routes.MultiTablePaging
 
@@ -1039,14 +1039,14 @@ withMockedGalley opts handler action =
 withMockedFederatorAndGalley ::
   Opt.Opts ->
   Domain ->
-  OutwardResponse ->
+  (FederatedRequest -> OutwardResponse) ->
   (ReceivedRequest -> MockT IO Wai.Response) ->
   Session a ->
   IO (a, Mock.ReceivedRequests, [ReceivedRequest])
 withMockedFederatorAndGalley opts domain fedResp galleyHandler action = do
   result <- assertRight <=< runExceptT $
     withTempMockedService initState galleyHandler $ \galleyMockState ->
-      Mock.withTempMockFederator (Mock.initState domain) (const (pure fedResp)) $ \fedMockState -> do
+      Mock.withTempMockFederator (Mock.initState domain) (pure . fedResp) $ \fedMockState -> do
         let opts' =
               opts
                 { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort galleyMockState)),

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

@@ -530,7 +530,6 @@ rmUser user conn = do
       page' <- liftSem $ listTeams user (Just (pageState page)) maxBound
       leaveTeams page'
 
-    -- FUTUREWORK: Ensure that remote members of local convs get notified of this activity
     leaveLocalConversations :: Member MemberStore r => [ConvId] -> Galley r ()
     leaveLocalConversations ids = do
       localDomain <- viewFederationDomain

services/galley/test/integration/API.hs

@@ -3198,26 +3198,35 @@ removeUser = do
   c <- view tsCannon
   [alice, alexDel, amy] <- replicateM 3 randomQualifiedUser
   let [alice', alexDel', amy'] = qUnqualified <$> [alice, alexDel, amy]
+
   let bDomain = Domain "b.example.com"
   bart <- randomQualifiedId bDomain
   berta <- randomQualifiedId bDomain
+
   let cDomain = Domain "c.example.com"
   carl <- randomQualifiedId cDomain
 
+  let dDomain = Domain "d.example.com"
+  dwight <- randomQualifiedId dDomain
+  dory <- randomQualifiedId dDomain
+
   connectUsers alice' (list1 alexDel' [amy'])
   connectWithRemoteUser alice' bart
   connectWithRemoteUser alice' berta
   connectWithRemoteUser alexDel' bart
   connectWithRemoteUser alice' carl
   connectWithRemoteUser alexDel' carl
+  connectWithRemoteUser alice' dwight
+  connectWithRemoteUser alexDel' dory
 
   convA1 <- decodeConvId <$> postConv alice' [alexDel'] (Just "gossip") [] Nothing Nothing
-  convA2 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, amy, berta]}
+  convA2 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, amy, berta, dwight]}
   convA3 <- decodeConvId <$> postConv alice' [amy'] (Just "gossip3") [] Nothing Nothing
   convA4 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, bart, carl]}
   convB1 <- randomId -- a remote conversation at 'bDomain' that Alice, AlexDel and Bart will be in
   convB2 <- randomId -- a remote conversation at 'bDomain' that AlexDel and Bart will be in
   convC1 <- randomId -- a remote conversation at 'cDomain' that AlexDel and Carl will be in
+  convD1 <- randomId -- a remote conversation at 'cDomain' that AlexDel and Dory will be in
   let qconvA1 = Qualified convA1 (qDomain alexDel)
       qconvA2 = Qualified convA2 (qDomain alexDel)
 
@@ -3239,23 +3248,34 @@ removeUser = do
   FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB1 bart [alice, alexDel]
   FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB2 bart [alexDel]
   FederatedGalley.onConversationCreated fedGalleyClient cDomain $ nc convC1 carl [alexDel]
-
-  localDomain <- viewFederationDomain
+  FederatedGalley.onConversationCreated fedGalleyClient dDomain $ nc convD1 dory [alexDel]
 
   WS.bracketR3 c alice' alexDel' amy' $ \(wsAlice, wsAlexDel, wsAmy) -> do
-    let galleyApi _domain =
-          emptyFederatedGalley
-            { FederatedGalley.leaveConversation = \_domain _update ->
-                pure (FederatedGalley.LeaveConversationResponse (Right ())),
-              FederatedGalley.onConversationUpdated = \_domain _convUpdate ->
-                pure ()
-            }
+    let handler :: F.FederatedRequest -> IO F.OutwardResponse
+        handler freq@(Domain . F.domain -> domain)
+          | domain == dDomain =
+            pure
+              ( F.OutwardResponseError
+                  ( F.OutwardError
+                      F.ConnectionRefused
+                      "mocked: dDomain is unavailable"
+                  )
+              )
+          | domain `elem` [bDomain, cDomain] =
+            case F.path <$> F.request freq of
+              (Just "/federation/leave-conversation") ->
+                pure (F.OutwardResponseBody (cs (encode (FederatedGalley.LeaveConversationResponse (Right ())))))
+              (Just "federation/on-conversation-updated") ->
+                pure (F.OutwardResponseBody (cs (encode ())))
+              other -> error $ "unmocked path " <> show other
+          | otherwise = error "unmocked domain"
+
     (_, fedRequests) <-
-      withTempServantMockFederator (const emptyFederatedBrig) galleyApi localDomain $
+      withTempMockFederator' handler $
         deleteUser alexDel' !!! const 200 === statusCode
 
     liftIO $ do
-      assertEqual ("expect exactly 5 federated requests in : " <> show fedRequests) 5 (length fedRequests)
+      assertEqual ("expect exactly 7 federated requests in : " <> show fedRequests) 7 (length fedRequests)
 
     liftIO $ do
       bReq <- assertOne $ filter (matchFedRequest bDomain "/federation/on-user-deleted/conversations") fedRequests
@@ -3273,6 +3293,14 @@ removeUser = do
       sort (fromRange (FederatedGalley.udcnConversations udcnC)) @?= sort [convC1]
       FederatedGalley.udcnUser udcnC @?= qUnqualified alexDel
 
+    liftIO $ do
+      dReq <- assertOne $ filter (matchFedRequest dDomain "/federation/on-user-deleted/conversations") fedRequests
+      fmap F.component (F.request dReq) @?= Just F.Galley
+      fmap F.path (F.request dReq) @?= Just "/federation/on-user-deleted/conversations"
+      Just (Right udcnD) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request dReq)
+      sort (fromRange (FederatedGalley.udcnConversations udcnD)) @?= sort [convD1]
+      FederatedGalley.udcnUser udcnD @?= qUnqualified alexDel
+
     liftIO $ do
       WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel] $
         wsAssertMembersLeave qconvA1 alexDel [alexDel]
@@ -3299,6 +3327,13 @@ removeUser = do
       cuAction convUpdate @?= ConversationActionRemoveMembers (pure alexDel)
       cuAlreadyPresentUsers convUpdate @?= [qUnqualified carl]
 
+    liftIO $ do
+      dConvUpdateRPC <- assertOne $ filter (matchFedRequest dDomain "/federation/on-conversation-updated") fedRequests
+      Just (Right convUpdate) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request dConvUpdateRPC)
+      cuConvId convUpdate @?= convA2
+      cuAction convUpdate @?= ConversationActionRemoveMembers (pure alexDel)
+      cuAlreadyPresentUsers convUpdate @?= [qUnqualified dwight]
+
   -- Check memberships
   mems1 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA1
   mems2 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA2