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/galley.cabal

@@ -532,6 +532,7 @@ executable galley-integration
     , unordered-containers
     , uri-bytestring
     , uuid
+    , uuid-types
     , vector
     , wai
     , wai-extra

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

@@ -31,6 +31,7 @@ module Galley.API.Message
     QualifiedMismatch (..),
     mkQualifiedUserClients,
     clientMismatchStrategyApply,
+    collectFailedToSend,
   )
 where
 
@@ -217,11 +218,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 +426,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 = tUnqualified l
       -- check if the sender client exists (as one of the clients in the conversation)
       unless
         ( Set.member
@@ -452,7 +465,6 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg =
             . runError @LegalholdConflicts
             $ guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients
         throw e
-
       failedToSend <-
         sendMessages @'NormalMessage
           now
@@ -463,7 +475,49 @@ 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'
+          -- Failed users/clients aren't redundant
+          (failed, redundant) = partition predicate redundant'
+      pure
+        otrResult
+          { mssFailedToSend =
+              QualifiedUserClients $
+                collectFailedToSend
+                  [ qualifiedUserClients failedToSend,
+                    qualifiedUserClients failedToSendFetchingClients,
+                    fromDomUserClient failed
+                  ],
+            mssRedundantClients = QualifiedUserClients $ fromDomUserClient redundant
+          }
+  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 buildUserClientMap mempty
+      where
+        buildUserClientMap :: (Domain, (UserId, Set ClientId)) -> Map Domain (Map UserId (Set ClientId)) -> Map Domain (Map UserId (Set ClientId))
+        buildUserClientMap (d, (u, c)) m = Map.alter (pure . Map.alter (pure . Set.union c . fromMaybe mempty) u . fromMaybe mempty) d m
+
+collectFailedToSend ::
+  Foldable f =>
+  f (Map Domain (Map UserId (Set ClientId))) ->
+  Map Domain (Map UserId (Set ClientId))
+collectFailedToSend = foldr (Map.unionWith (Map.unionWith Set.union)) mempty
 
 makeUserMap :: Set UserId -> Map UserId (Set ClientId) -> Map UserId (Set ClientId)
 makeUserMap keys = (<> Map.fromSet (const mempty) keys)

services/galley/test/integration/API.hs

@@ -62,9 +62,11 @@ import Data.Singletons
 import qualified Data.Text as T
 import qualified Data.Text.Ascii as Ascii
 import Data.Time.Clock (getCurrentTime)
+import Data.UUID.Types
 import Federator.Discovery (DiscoveryFailure (..))
 import Federator.MockServer
 import Galley.API.Mapping
+import Galley.API.Message
 import Galley.Options (optFederator)
 import Galley.Types.Conversations.Members
 import Imports
@@ -220,6 +222,8 @@ 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 get clients and failed to send clients" postMessageQualifiedLocalOwningBackendFailedToSendClientsFailingGetUserClients,
+          test s "build failed to send map for post message qualified" testBuildFailedToSend,
           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 +1152,149 @@ 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.
+postMessageQualifiedLocalOwningBackendFailedToSendClientsFailingGetUserClients :: TestM ()
+postMessageQualifiedLocalOwningBackendFailedToSendClientsFailingGetUserClients = 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
+  emilyId <- randomId
+  emilyClient <- liftIO $ generate arbitrary
+  let remoteDomain = Domain "far-away.example.com"
+      deeRemote = Qualified deeId remoteDomain
+      remoteDomain2 = Domain "far-away2.example.com"
+      emilyRemote = Qualified emilyId remoteDomain2
+
+  let aliceUnqualified = qUnqualified aliceOwningDomain
+      bobUnqualified = qUnqualified bobOwningDomain
+      chadUnqualified = qUnqualified chadOwningDomain
+
+  connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain])
+  connectWithRemoteUser aliceUnqualified deeRemote
+  connectWithRemoteUser aliceUnqualified emilyRemote
+
+  -- FUTUREWORK: Do this test with more than one remote domains
+  resp <-
+    postConvWithRemoteUsers
+      aliceUnqualified
+      defNewProteusConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote, emilyRemote]}
+  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"),
+            (emilyRemote, emilyClient, "text-for-emily")
+          ]
+
+    let mock =
+          ( do
+              -- Dee is always unavailable,
+              -- Emily is paritally available
+              guardRPC "get-user-clients"
+              d <- frTargetDomain <$> getRequest
+              if d == remoteDomain
+                then throw (MockErrorResponse HTTP.status503 "Down for maintenance.")
+                else mockReply $ UserMap (Map.singleton (qUnqualified emilyRemote) (Set.singleton (PubClient emilyClient Nothing)))
+          )
+            <|> ( 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)
+                  ]
+              ),
+              ( remoteDomain2,
+                Map.fromList
+                  [ (emilyId, Set.singleton emilyClient)
+                  ]
+              )
+            ]
+    pure resp2 !!! do
+      const 201 === statusCode
+      assertMismatchQualified expectedFailedToSend mempty mempty 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)
+
+testBuildFailedToSend :: TestM ()
+testBuildFailedToSend = liftIO $ do
+  assertEqual
+    "Empty case - trivial"
+    (collectFailedToSend [])
+    mempty
+  assertEqual
+    "Empty case - single empty map"
+    (collectFailedToSend [mempty])
+    mempty
+  assertEqual
+    "Empty case - multiple empty maps"
+    (collectFailedToSend [mempty, mempty])
+    mempty
+  assertEqual
+    "Single domain"
+    (collectFailedToSend [Map.singleton (Domain "foo") mempty])
+    (Map.singleton (Domain "foo") mempty)
+  assertEqual
+    "Single domain duplicated"
+    (collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "foo") mempty])
+    (Map.singleton (Domain "foo") mempty)
+  assertEqual
+    "Mutliple domains in multiple maps"
+    (collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "bar") mempty])
+    (Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)])
+  assertEqual
+    "Mutliple domains in single map"
+    (collectFailedToSend [Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)]])
+    (Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)])
+  assertEqual
+    "Single domain duplicated with unique sub-maps"
+    ( collectFailedToSend
+        [ Map.singleton (Domain "foo") $ Map.singleton idA mempty,
+          Map.singleton (Domain "foo") $ Map.singleton idB mempty
+        ]
+    )
+    ( Map.singleton (Domain "foo") $
+        Map.fromList
+          [ (idA, mempty),
+            (idB, mempty)
+          ]
+    )
+  where
+    idA = Id $ fromJust $ Data.UUID.Types.fromString "aaaaaaaa-aaaa-aaaa-aaaa-aaaaaaaaaaaa"
+    idB = Id $ fromJust $ Data.UUID.Types.fromString "bbbbbbbb-bbbb-bbbb-bbbb-bbbbbbbbbbbb"
+
 postMessageQualifiedRemoteOwningBackendFailure :: TestM ()
 postMessageQualifiedRemoteOwningBackendFailure = do
   (aliceLocal, aliceClient) <- randomUserWithClientQualified (head someLastPrekeys)