diff --git a/changelog.d/6-federation/fs-51-report-federation-sending-errors b/changelog.d/6-federation/fs-51-report-federation-sending-errors new file mode 100644 index 00000000000..54177244671 --- /dev/null +++ b/changelog.d/6-federation/fs-51-report-federation-sending-errors @@ -0,0 +1 @@ +Report federated Proteus message sending errors to clients \ No newline at end of file diff --git a/services/galley/default.nix b/services/galley/default.nix index 5f5ac943ce9..3b94c838df5 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -117,6 +117,7 @@ , unordered-containers , uri-bytestring , uuid +, uuid-types , vector , wai , wai-extra @@ -337,6 +338,7 @@ mkDerivation { unordered-containers uri-bytestring uuid + uuid-types vector wai wai-extra @@ -374,6 +376,7 @@ mkDerivation { tasty-quickcheck transformers types-common + uuid-types wai wai-predicates wire-api diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index ac1d204da6d..4e94167b012 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -532,6 +532,7 @@ executable galley-integration , unordered-containers , uri-bytestring , uuid + , uuid-types , vector , wai , wai-extra @@ -859,6 +860,7 @@ test-suite galley-tests , tasty-quickcheck , transformers , types-common + , uuid-types , wai , wai-predicates , wire-api diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 5ed9bdbde31..585c721cb9b 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/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) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 9f284614303..ff5dd1b6a54 100644 --- a/services/galley/test/integration/API.hs +++ b/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 get clients and failed to send clients" postMessageQualifiedLocalOwningBackendFailedToSendClientsFailingGetUserClients, 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, @@ -1151,6 +1152,103 @@ 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 + Nothing + 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) + postMessageQualifiedRemoteOwningBackendFailure :: TestM () postMessageQualifiedRemoteOwningBackendFailure = do (aliceLocal, aliceClient) <- randomUserWithClientQualified (head someLastPrekeys) diff --git a/services/galley/test/unit/Test/Galley/API/Message.hs b/services/galley/test/unit/Test/Galley/API/Message.hs index e2b0f63e27a..25575bdcb1f 100644 --- a/services/galley/test/unit/Test/Galley/API/Message.hs +++ b/services/galley/test/unit/Test/Galley/API/Message.hs @@ -18,11 +18,12 @@ module Test.Galley.API.Message where import Control.Lens -import Data.Domain (Domain) -import Data.Id (ClientId, UserId) +import Data.Domain +import Data.Id import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set.Lens +import Data.UUID.Types import Galley.API.Message import Imports import Test.Tasty @@ -40,7 +41,8 @@ tests = checkMessageClientEverythingReported, checkMessageClientRedundantSender, checkMessageClientMissingSubsetOfStrategy - ] + ], + testBuildFailedToSend ] flatten :: Map Domain (Map UserId (Set ClientId)) -> Set (Domain, UserId, ClientId) @@ -100,3 +102,53 @@ checkMessageClientMissingSubsetOfStrategy = testProperty "missing clients should (_, _, mismatch) = checkMessageClients sender expectedMap msg strat missing = flatten . qualifiedUserClients $ qmMissing mismatch in Set.isSubsetOf missing stratClients + +testBuildFailedToSend :: TestTree +testBuildFailedToSend = + testGroup + "build failed to send map for post message qualified" + [ testProperty + "Empty case - trivial" + $ collectFailedToSend [] + === mempty, + testProperty + "Empty case - single empty map" + $ collectFailedToSend [mempty] + === mempty, + testProperty + "Empty case - multiple empty maps" + $ collectFailedToSend [mempty, mempty] + === mempty, + testProperty + "Single domain" + $ collectFailedToSend [Map.singleton (Domain "foo") mempty] + === Map.singleton (Domain "foo") mempty, + testProperty + "Single domain duplicated" + $ collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "foo") mempty] + === Map.singleton (Domain "foo") mempty, + testProperty + "Mutliple domains in multiple maps" + $ collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "bar") mempty] + === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)], + testProperty + "Mutliple domains in single map" + $ collectFailedToSend [Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)]] + === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)], + testProperty + "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"