FS-51 Report unavailable clients for Proteus messages

changelog.d/6-federation/fs-51-report-federation-sending-errors

@@ -0,0 +1 @@
+Report federated Proteus message sending errors to clients

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

@@ -217,11 +217,12 @@ checkMessageClients sender participantMap recipientMap mismatchStrat =
 getRemoteClients ::
   (Member FederatorAccess r) =>
   [RemoteMember] ->
-  Sem r (Map (Domain, UserId) (Set ClientId))
+  Sem r [Either (Remote [UserId], FederationError) (Map (Domain, UserId) (Set ClientId))]
 getRemoteClients remoteMembers =
   -- concatenating maps is correct here, because their sets of keys are disjoint
-  mconcat . map tUnqualified
-    <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain
+  -- Use runFederatedConcurrentlyEither so we can catch federation errors and report to clients
+  -- which domains and users aren't contactable at the moment.
+  tUnqualified <$$$> runFederatedConcurrentlyEither (map rmId remoteMembers) getRemoteClientsFromDomain
   where
     getRemoteClientsFromDomain :: Remote [UserId] -> FederatorClient 'Brig (Map (Domain, UserId) (Set ClientId))
     getRemoteClientsFromDomain (tUntagged -> Qualified uids domain) =
@@ -424,8 +425,19 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg =
 
       -- get remote clients
       qualifiedRemoteClients <- getRemoteClients (convRemoteMembers conv)
-      let qualifiedClients = qualifiedLocalClients <> qualifiedRemoteClients
-
+      let qualifiedClients = qualifiedLocalClients <> qualifiedRemoteClients'
+          -- concatenating maps is correct here, because their sets of keys are disjoint
+          qualifiedRemoteClients' = mconcat $ rights qualifiedRemoteClients
+          -- Collect the list of users and their domains that we weren't able to fetch clients for.
+          failedToSendFetchingClients :: QualifiedUserClients
+          failedToSendFetchingClients =
+            QualifiedUserClients . mconcat $ extractUserMap . fst <$> lefts qualifiedRemoteClients
+            where
+              extractUserMap :: Remote [UserId] -> Map Domain (Map UserId (Set ClientId))
+              extractUserMap l = Map.singleton domain $ Map.fromList $ (,mempty) <$> users
+                where
+                  domain = qDomain $ tUntagged l
+                  users = qUnqualified $ tUntagged l
       -- check if the sender client exists (as one of the clients in the conversation)
       unless
         ( Set.member
@@ -452,7 +464,6 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg =
             . runError @LegalholdConflicts
             $ guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients
         throw e
-
       failedToSend <-
         sendMessages @'NormalMessage
           now
@@ -463,7 +474,44 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg =
           botMap
           (qualifiedNewOtrMetadata msg)
           validMessages
-      pure otrResult {mssFailedToSend = failedToSend}
+
+      let -- List of the clients that are initially flagged as redundant.
+          redundant' = toDomUserClient $ qualifiedUserClients $ mssRedundantClients otrResult
+          -- List of users that we couldn't fetch clients for. Used to get their "redundant"
+          -- clients for reporting as failedToSend.
+          failed' = toDomUserClient $ qualifiedUserClients failedToSendFetchingClients
+          -- failedToSendFetchingClients doesn't contain client IDs, so those need to be excluded
+          -- from the filter search. We have to focus on only the domain and user. These clients
+          -- should be listed in the failedToSend field however, as tracking these clients is an
+          -- important part of the proteus protocol.
+          predicate (d, (u, _)) = any (\(d', (u', _)) -> d == d' && u == u') failed'
+          redundantFailed = filter predicate redundant'
+      pure
+        otrResult
+          { mssFailedToSend =
+              QualifiedUserClients $
+                foldr
+                  (Map.unionWith (Map.unionWith Set.union))
+                  mempty
+                  [ qualifiedUserClients failedToSend,
+                    qualifiedUserClients failedToSendFetchingClients,
+                    fromDomUserClient redundantFailed
+                  ]
+          }
+  where
+    -- Get the triples for domains, users, and clients so we can easily filter
+    -- out the values from redundant clients that should be in failed to send.
+    toDomUserClient :: Map Domain (Map UserId (Set ClientId)) -> [(Domain, (UserId, Set ClientId))]
+    toDomUserClient m = do
+      (d, m') <- Map.assocs m
+      (d,) <$> Map.assocs m'
+    -- Rebuild the map, concatenating results along the way.
+    fromDomUserClient :: [(Domain, (UserId, Set ClientId))] -> Map Domain (Map UserId (Set ClientId))
+    fromDomUserClient = foldr f mempty
+      where
+        f :: (Domain, (UserId, Set ClientId)) -> Map Domain (Map UserId (Set ClientId)) -> Map Domain (Map UserId (Set ClientId))
+        f (d, (u, c)) m = Map.alter (pure . Map.alter (g c . fromMaybe mempty) u . fromMaybe mempty) d m
+        g c = pure . Set.union c
 
 makeUserMap :: Set UserId -> Map UserId (Set ClientId) -> Map UserId (Set ClientId)
 makeUserMap keys = (<> Map.fromSet (const mempty) keys)

services/galley/test/integration/API.hs

@@ -220,6 +220,7 @@ tests s =
           test s "post message qualified - local owning backend - redundant and deleted clients" postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients,
           test s "post message qualified - local owning backend - ignore missing" postMessageQualifiedLocalOwningBackendIgnoreMissingClients,
           test s "post message qualified - local owning backend - failed to send clients" postMessageQualifiedLocalOwningBackendFailedToSendClients,
+          test s "post message qualified - local owning backend - failed to send clients 2" postMessageQualifiedLocalOwningBackendFailedToSendClients2,
           test s "post message qualified - remote owning backend - federation failure" postMessageQualifiedRemoteOwningBackendFailure,
           test s "post message qualified - remote owning backend - success" postMessageQualifiedRemoteOwningBackendSuccess,
           test s "join conversation" postJoinConvOk,
@@ -1148,6 +1149,85 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients = do
       WS.assertMatch_ t wsBob (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient bobClient encodedTextForBob)
       WS.assertMatch_ t wsChad (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient chadClient encodedTextForChad)
 
+-- This test is similar to postMessageQualifiedLocalOwningBackendFailedToSendClients
+-- except that both of the calls to the federated server are failing.
+postMessageQualifiedLocalOwningBackendFailedToSendClients2 :: TestM ()
+postMessageQualifiedLocalOwningBackendFailedToSendClients2 = do
+  -- WS receive timeout
+  let t = 5 # Second
+  -- Cannon for local users
+  cannon <- view tsCannon
+  -- Domain which owns the converstaion
+  owningDomain <- viewFederationDomain
+
+  (aliceOwningDomain, aliceClient) <- randomUserWithClientQualified (head someLastPrekeys)
+  (bobOwningDomain, bobClient) <- randomUserWithClientQualified (someLastPrekeys !! 1)
+  bobClient2 <- randomClient (qUnqualified bobOwningDomain) (someLastPrekeys !! 2)
+  (chadOwningDomain, chadClient) <- randomUserWithClientQualified (someLastPrekeys !! 3)
+  deeId <- randomId
+  deeClient <- liftIO $ generate arbitrary
+  let remoteDomain = Domain "far-away.example.com"
+      deeRemote = Qualified deeId remoteDomain
+
+  let aliceUnqualified = qUnqualified aliceOwningDomain
+      bobUnqualified = qUnqualified bobOwningDomain
+      chadUnqualified = qUnqualified chadOwningDomain
+
+  connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain])
+  connectWithRemoteUser aliceUnqualified deeRemote
+
+  -- FUTUREWORK: Do this test with more than one remote domains
+  resp <-
+    postConvWithRemoteUsers
+      aliceUnqualified
+      defNewProteusConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]}
+  let convId = (`Qualified` owningDomain) . decodeConvId $ resp
+
+  WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do
+    let message =
+          [ (bobOwningDomain, bobClient, "text-for-bob"),
+            (bobOwningDomain, bobClient2, "text-for-bob2"),
+            (chadOwningDomain, chadClient, "text-for-chad"),
+            (deeRemote, deeClient, "text-for-dee")
+          ]
+
+    let mock =
+          ( guardRPC "get-user-clients"
+              *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")
+          )
+            <|> ( guardRPC "on-message-sent"
+                    *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")
+                )
+
+    (resp2, _requests) <- withTempMockFederator' mock $
+      postProteusMessageQualified
+        aliceUnqualified
+        aliceClient
+        convId
+        message
+        "data"
+        Message.MismatchReportAll
+
+    let expectedFailedToSend =
+          QualifiedUserClients . Map.fromList $
+            [ ( remoteDomain,
+                Map.fromList
+                  [ (deeId, Set.singleton deeClient)
+                  ]
+              )
+            ]
+        expectedRedundant = expectedFailedToSend
+    pure resp2 !!! do
+      const 201 === statusCode
+      assertMismatchQualified expectedFailedToSend mempty expectedRedundant mempty
+
+    liftIO $ do
+      let encodedTextForBob = toBase64Text "text-for-bob"
+          encodedTextForChad = toBase64Text "text-for-chad"
+          encodedData = toBase64Text "data"
+      WS.assertMatch_ t wsBob (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient bobClient encodedTextForBob)
+      WS.assertMatch_ t wsChad (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient chadClient encodedTextForChad)
+
 postMessageQualifiedRemoteOwningBackendFailure :: TestM ()
 postMessageQualifiedRemoteOwningBackendFailure = do
   (aliceLocal, aliceClient) <- randomUserWithClientQualified (head someLastPrekeys)