FS-1467: Make conversation metadata APIs fault tolerant to federation errors

changelog.d/1-api-changes/FS-1467

@@ -0,0 +1 @@
+Updating conversation meta-data APIs to be fault tolerant of unavailable federation servers.

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

@@ -632,9 +632,15 @@ updateLocalConversationUnchecked lconv qusr con action = do
   (extraTargets, action') <- performAction tag qusr lconv action
 
   notifyConversationAction
-    -- Removing members should be fault tolerant.
     ( case tag of
+        -- Removing members should be fault tolerant.
         SConversationRemoveMembersTag -> False
+        -- Conversation metadata updates should be fault tolerant.
+        SConversationRenameTag -> False
+        SConversationMessageTimerUpdateTag -> False
+        SConversationReceiptModeUpdateTag -> False
+        SConversationAccessDataTag -> False
+        SConversationMemberUpdateTag -> False
         _ -> True
     )
     (sing @tag)

services/galley/test/integration/API.hs

@@ -203,6 +203,7 @@ tests s =
           test s "rename conversation" putConvRenameOk,
           test s "rename qualified conversation" putQualifiedConvRenameOk,
           test s "rename qualified conversation with remote members" putQualifiedConvRenameWithRemotesOk,
+          test s "rename qualified conversation with unavailable remote" putQualifiedConvRenameWithRemotesUnavailable,
           test s "rename qualified conversation failure" putQualifiedConvRenameFailure,
           test s "other member update role" putOtherMemberOk,
           test s "qualified other member update role" putQualifiedOtherMemberOk,
@@ -216,6 +217,7 @@ tests s =
           test s "remote conversation member update (everything)" putRemoteConvMemberAllOk,
           test s "conversation receipt mode update" putReceiptModeOk,
           test s "conversation receipt mode update with remote members" putReceiptModeWithRemotesOk,
+          test s "conversation receipt mode update with unavailable remote members" putReceiptModeWithRemotesUnavailable,
           test s "remote conversation receipt mode update" putRemoteReceiptModeOk,
           test s "leave connect conversation" leaveConnectConversation,
           test s "post conversations/:cnv/otr/message: message delivery and missing clients" postCryptoMessageVerifyMsgSentAndRejectIfMissingClient,
@@ -238,6 +240,7 @@ tests s =
           test s "convert invite to code-access conversation" postConvertCodeConv,
           test s "convert code to team-access conversation" postConvertTeamConv,
           test s "local and remote guests are removed when access changes" testAccessUpdateGuestRemoved,
+          test s "local and remote guests are removed when access changes remotes unavailable" testAccessUpdateGuestRemovedRemotesUnavailable,
           test s "team member can't join via guest link if access role removed" testTeamMemberCantJoinViaGuestLinkIfAccessRoleRemoved,
           test s "cannot join private conversation" postJoinConvFail,
           test s "revoke guest links for team conversation" testJoinTeamConvGuestLinksDisabled,
@@ -1846,6 +1849,92 @@ testAccessUpdateGuestRemoved = do
 
 -- @END
 
+testAccessUpdateGuestRemovedRemotesUnavailable :: TestM ()
+testAccessUpdateGuestRemovedRemotesUnavailable = do
+  -- alice, bob are in a team
+  (tid, alice, [bob]) <- createBindingTeamWithQualifiedMembers 2
+
+  -- charlie is a local guest
+  charlie <- randomQualifiedUser
+  connectUsers (qUnqualified alice) (pure (qUnqualified charlie))
+
+  -- dee is a remote guest
+  let remoteDomain = Domain "far-away.example.com"
+  dee <- Qualified <$> randomId <*> pure remoteDomain
+
+  connectWithRemoteUser (qUnqualified alice) dee
+
+  -- they are all in a local conversation
+  conv <-
+    responseJsonError
+      =<< postConvWithRemoteUsers
+        (qUnqualified alice)
+        Nothing
+        defNewProteusConv
+          { newConvQualifiedUsers = [bob, charlie, dee],
+            newConvTeam = Just (ConvTeamInfo tid)
+          }
+        <!! const 201 === statusCode
+
+  c <- view tsCannon
+  WS.bracketRN c (map qUnqualified [alice, bob, charlie]) $ \[wsA, wsB, wsC] -> do
+    -- conversation access role changes to team only
+    (_, reqs) <- withTempMockFederator' (throw $ MockErrorResponse HTTP.status503 "Down for maintenance") $ do
+      -- This request should still succeed even with an unresponsive federation member.
+      putQualifiedAccessUpdate
+        (qUnqualified alice)
+        (cnvQualifiedId conv)
+        (ConversationAccessData mempty (Set.fromList [TeamMemberAccessRole]))
+        !!! const 200 === statusCode
+      -- charlie and dee are kicked out
+      --
+      -- 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) alice [charlie]
+      WS.assertMatchN_ (5 # Second) [wsA, wsB, wsC] $
+        wsAssertMembersLeave (cnvQualifiedId conv) alice [dee]
+
+    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 $
+      compareLists
+        ( map
+            ( \fr -> do
+                cu <- eitherDecode (frBody fr)
+                pure (F.cuOrigUserId cu, F.cuAction cu)
+            )
+            ( filter
+                ( \fr ->
+                    frComponent fr == Galley
+                      && frRPC fr == "on-conversation-updated"
+                )
+                reqs
+            )
+        )
+        [ 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 <-
+    responseJsonError
+      =<< getConvQualified (qUnqualified alice) (cnvQualifiedId conv)
+        <!! const 200 === statusCode
+  liftIO $ map omQualifiedId (cmOthers (cnvMembers conv2)) @?= [bob]
+
+-- @END
+
 testTeamMemberCantJoinViaGuestLinkIfAccessRoleRemoved :: TestM ()
 testTeamMemberCantJoinViaGuestLinkIfAccessRoleRemoved = do
   -- given alice, bob, charlie and dee are in a team
@@ -3537,6 +3626,46 @@ putQualifiedConvRenameWithRemotesOk = do
       evtFrom e @?= qbob
       evtData e @?= EdConvRename (ConversationRename "gossip++")
 
+putQualifiedConvRenameWithRemotesUnavailable :: TestM ()
+putQualifiedConvRenameWithRemotesUnavailable = do
+  c <- view tsCannon
+  let remoteDomain = Domain "alice.example.com"
+  qalice <- Qualified <$> randomId <*> pure remoteDomain
+  qbob <- randomQualifiedUser
+  let bob = qUnqualified qbob
+
+  connectWithRemoteUser bob qalice
+
+  resp <-
+    postConvWithRemoteUsers
+      bob
+      Nothing
+      defNewProteusConv {newConvQualifiedUsers = [qalice]}
+      <!! const 201 === statusCode
+  let qconv = decodeQualifiedConvId resp
+
+  WS.bracketR c bob $ \wsB -> do
+    (_, requests) <-
+      withTempMockFederator' (throw $ MockErrorResponse HTTP.status503 "Down for maintenance") $
+        putQualifiedConversationName bob qconv "gossip++" !!! const 200 === statusCode
+
+    req <- assertOne requests
+    liftIO $ do
+      frTargetDomain req @?= remoteDomain
+      frComponent req @?= Galley
+      frRPC req @?= "on-conversation-updated"
+      Right cu <- pure . eitherDecode . frBody $ req
+      F.cuConvId cu @?= qUnqualified qconv
+      F.cuAction cu @?= SomeConversationAction (sing @'ConversationRenameTag) (ConversationRename "gossip++")
+
+    void . liftIO . WS.assertMatch (5 # Second) wsB $ \n -> do
+      let e = List1.head (WS.unpackPayload n)
+      ntfTransient n @?= False
+      evtConv e @?= qconv
+      evtType e @?= ConvRename
+      evtFrom e @?= qbob
+      evtData e @?= EdConvRename (ConversationRename "gossip++")
+
 putConvDeprecatedRenameOk :: TestM ()
 putConvDeprecatedRenameOk = do
   c <- view tsCannon
@@ -4025,6 +4154,48 @@ putReceiptModeWithRemotesOk = do
         @?= EdConvReceiptModeUpdate
           (ConversationReceiptModeUpdate (ReceiptMode 43))
 
+putReceiptModeWithRemotesUnavailable :: TestM ()
+putReceiptModeWithRemotesUnavailable = do
+  c <- view tsCannon
+  let remoteDomain = Domain "alice.example.com"
+  qalice <- Qualified <$> randomId <*> pure remoteDomain
+  qbob <- randomQualifiedUser
+  let bob = qUnqualified qbob
+
+  connectWithRemoteUser bob qalice
+
+  resp <-
+    postConvWithRemoteUsers
+      bob
+      Nothing
+      defNewProteusConv {newConvQualifiedUsers = [qalice]}
+  let qconv = decodeQualifiedConvId resp
+
+  WS.bracketR c bob $ \wsB -> do
+    (_, requests) <-
+      withTempMockFederator' (throw $ MockErrorResponse HTTP.status503 "Down for maintenance") $
+        putQualifiedReceiptMode bob qconv (ReceiptMode 43) !!! const 200 === statusCode
+
+    req <- assertOne requests
+    liftIO $ do
+      frTargetDomain req @?= remoteDomain
+      frComponent req @?= Galley
+      frRPC req @?= "on-conversation-updated"
+      Right cu <- pure . eitherDecode . frBody $ req
+      F.cuConvId cu @?= qUnqualified qconv
+      F.cuAction cu
+        @?= SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) (ConversationReceiptModeUpdate (ReceiptMode 43))
+
+    void . liftIO . WS.assertMatch (5 # Second) wsB $ \n -> do
+      let e = List1.head (WS.unpackPayload n)
+      ntfTransient n @?= False
+      evtConv e @?= qconv
+      evtType e @?= ConvReceiptModeUpdate
+      evtFrom e @?= qbob
+      evtData e
+        @?= EdConvReceiptModeUpdate
+          (ConversationReceiptModeUpdate (ReceiptMode 43))
+
 postTypingIndicatorsV2 :: TestM ()
 postTypingIndicatorsV2 = do
   c <- view tsCannon

services/galley/test/integration/API/Federation.hs

@@ -21,6 +21,7 @@ module API.Federation where
 import API.Util
 import Bilge hiding (head)
 import Bilge.Assert
+import Control.Exception
 import Control.Lens hiding ((#))
 import qualified Data.Aeson as A
 import Data.ByteString.Conversion (toByteString')
@@ -42,6 +43,7 @@ import Data.Timeout (TimeoutUnit (..), (#))
 import Data.UUID.V4 (nextRandom)
 import Federator.MockServer
 import Imports
+import qualified Network.HTTP.Types as Http
 import Test.QuickCheck (arbitrary, generate)
 import Test.Tasty
 import qualified Test.Tasty.Cannon as WS
@@ -473,6 +475,51 @@ notifyUpdate extras action etype edata = do
         evtData e @?= edata
       WS.assertNoEvent (1 # Second) [wsC]
 
+notifyUpdateUnavailable :: [Qualified UserId] -> SomeConversationAction -> EventType -> EventData -> TestM ()
+notifyUpdateUnavailable extras action etype edata = do
+  c <- view tsCannon
+  qalice <- randomQualifiedUser
+  let alice = qUnqualified qalice
+  bob <- randomId
+  charlie <- randomUser
+  conv <- randomId
+  let bdom = Domain "bob.example.com"
+      qbob = Qualified bob bdom
+      qconv = Qualified conv bdom
+      mkMember quid = OtherMember quid Nothing roleNameWireMember
+  fedGalleyClient <- view tsFedGalleyClient
+
+  mapM_ (`connectWithRemoteUser` qbob) [alice]
+  registerRemoteConv
+    qconv
+    bob
+    (Just "gossip")
+    (Set.fromList (map mkMember (qalice : extras)))
+
+  now <- liftIO getCurrentTime
+  let cu =
+        FedGalley.ConversationUpdate
+          { FedGalley.cuTime = now,
+            FedGalley.cuOrigUserId = qbob,
+            FedGalley.cuConvId = conv,
+            FedGalley.cuAlreadyPresentUsers = [alice, charlie],
+            FedGalley.cuAction = action
+          }
+  WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do
+    ((), _fedRequests) <-
+      withTempMockFederator' (throw $ MockErrorResponse Http.status500 "Down for maintenance") $
+        runFedClient @"on-conversation-updated" fedGalleyClient bdom cu
+    putStrLn $ "on-conversation-updated: " <> show _fedRequests
+    liftIO $ do
+      WS.assertMatch_ (5 # Second) wsA $ \n -> do
+        let e = List1.head (WS.unpackPayload n)
+        ntfTransient n @?= False
+        evtConv e @?= qconv
+        evtType e @?= etype
+        evtFrom e @?= qbob
+        evtData e @?= edata
+      WS.assertNoEvent (1 # Second) [wsC]
+
 notifyConvRename :: TestM ()
 notifyConvRename = do
   let d = ConversationRename "gossip++"
@@ -505,6 +552,38 @@ notifyAccess = do
     ConvAccessUpdate
     (EdConvAccessUpdate d)
 
+notifyConvRenameUnavailable :: TestM ()
+notifyConvRenameUnavailable = do
+  let d = ConversationRename "gossip++"
+  notifyUpdateUnavailable [] (SomeConversationAction (sing @'ConversationRenameTag) d) ConvRename (EdConvRename d)
+
+notifyMessageTimerUnavailable :: TestM ()
+notifyMessageTimerUnavailable = do
+  let d = ConversationMessageTimerUpdate (Just 5000)
+  notifyUpdateUnavailable
+    []
+    (SomeConversationAction (sing @'ConversationMessageTimerUpdateTag) d)
+    ConvMessageTimerUpdate
+    (EdConvMessageTimerUpdate d)
+
+notifyReceiptModeUnavailable :: TestM ()
+notifyReceiptModeUnavailable = do
+  let d = ConversationReceiptModeUpdate (ReceiptMode 42)
+  notifyUpdateUnavailable
+    []
+    (SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) d)
+    ConvReceiptModeUpdate
+    (EdConvReceiptModeUpdate d)
+
+notifyAccessUnavailable :: TestM ()
+notifyAccessUnavailable = do
+  let d = ConversationAccessData (Set.fromList [InviteAccess, LinkAccess]) (Set.fromList [TeamMemberAccessRole])
+  notifyUpdateUnavailable
+    []
+    (SomeConversationAction (sing @'ConversationAccessDataTag) d)
+    ConvAccessUpdate
+    (EdConvAccessUpdate d)
+
 notifyMemberUpdate :: TestM ()
 notifyMemberUpdate = do
   qdee <- randomQualifiedUser