From 08547d13c260903e100e54c78d44dbdb0cdf7ec5 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Mon, 13 Feb 2023 19:09:20 +1000 Subject: [PATCH 01/10] FS-51 Report unavailable clients for Proteus messages Changing the return types to match the ticket. Adding tests and fixing some logic errors. --- .../fs-51-report-federation-sending-errors | 1 + services/galley/src/Galley/API/Message.hs | 62 +++++++++-- .../galley/test/integration/API/Federation.hs | 100 +++++++++++++++++- services/galley/test/integration/API/Util.hs | 15 ++- 4 files changed, 169 insertions(+), 9 deletions(-) create mode 100644 changelog.d/6-federation/fs-51-report-federation-sending-errors 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/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 2c95afe280b..d9aa51d2cda 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -216,11 +216,12 @@ checkMessageClients sender participantMap recipientMap mismatchStrat = getRemoteClients :: (Member FederatorAccess r, CallsFed 'Brig "get-user-clients") => [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 (tUntagged -> Qualified uids domain) = Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap @@ -424,7 +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 @@ -452,7 +465,6 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = . runError @LegalholdConflicts $ guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients throw e - failedToSend <- sendMessages @'NormalMessage now @@ -463,7 +475,45 @@ 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, _)) = none (\(d', (u', _)) -> d == d' && u == u') failed' + (redundant, redundantFailed) = partition predicate redundant' + pure + otrResult + { mssFailedToSend = + QualifiedUserClients $ + foldr + (Map.unionWith (Map.unionWith (<>))) + mempty + [ qualifiedUserClients failedToSend, + qualifiedUserClients failedToSendFetchingClients, + fromDomUserClient redundantFailed + ], + 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 f mempty + where + f (d, (u, c)) = Map.update (pure . Map.update (g c) u) d + g c = pure . mappend c 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/Federation.hs b/services/galley/test/integration/API/Federation.hs index 39c03e7feec..7f202ad7552 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -42,6 +42,8 @@ import Data.Timeout (TimeoutUnit (..), (#)) import Data.UUID.V4 (nextRandom) import Federator.MockServer import Imports +import Network.HTTP.Client +import Network.HTTP.Client.TLS import Test.QuickCheck (arbitrary, generate) import Test.Tasty import qualified Test.Tasty.Cannon as WS @@ -59,7 +61,7 @@ import Wire.API.Federation.Component import Wire.API.Internal.Notification import Wire.API.Message import Wire.API.Routes.Internal.Galley.ConversationsIntra -import Wire.API.User.Client (PubClient (..)) +import Wire.API.User.Client (PubClient (..), QualifiedUserClients (..)) import Wire.API.User.Profile tests :: IO TestSetup -> TestTree @@ -85,6 +87,7 @@ tests s = test s "POST /federation/leave-conversation : Invalid type" leaveConversationInvalidType, test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent, test s "POST /federation/send-message : Post a message sent from another backend" sendMessage, + test s "POST /federation/send-message : Ensure that messages are send when some backends are unavailable" sendMessageUnavailableFederation, test s "POST /federation/on-user-deleted-conversations : Remove deleted remote user from local conversations" onUserDeleted, test s "POST /federation/update-conversation : Update local conversation by a remote admin " updateConversationByRemoteAdmin ] @@ -918,6 +921,101 @@ sendMessage = do Map.keysSet (userClientMap (FedGalley.rmRecipients rm)) @?= Set.singleton chadId +-- alice local, bob and chad remote in a local conversation +-- alice sends a message, we test that alice receieves a list of clients +-- that the message wasn't sent to and that a call is made to the +-- onMessageSent RPC to inform chad +-- Reporting ticket: FS-51 +sendMessageUnavailableFederation :: TestM () +sendMessageUnavailableFederation = do + cannon <- view tsCannon + let remoteDomain = Domain "far-away.example.com" + localDomain <- viewFederationDomain + + -- users and clients + (alice, aliceClient) <- randomUserWithClientQualified (head someLastPrekeys) + let aliceId = qUnqualified alice + bobId <- randomId + bobClient <- liftIO $ generate arbitrary + let bob = Qualified bobId remoteDomain + bobProfile = mkProfile bob (Name "Bob") + connectWithRemoteUser aliceId bob + -- conversation + let responses1 = guardComponent Brig *> mockReply [bobProfile] + + (convId, requests1) <- + withTempMockFederator' (responses1 <|> mockReply ()) $ + fmap decodeConvId $ + postConvQualified + aliceId + defNewProteusConv + { newConvQualifiedUsers = [bob] + } + pure xs + _ -> assertFailure "unexpected number of requests" + frComponent galleyReq @?= Galley + frRPC galleyReq @?= "on-conversation-created" + + -- we use bilge instead of the federation client to make a federated request + -- here, because we need to make use of the mock federator, which at the moment + -- supports only bilge requests + let rcpts = + [ (bob, bobClient, "hi bob") + ] + msg = mkQualifiedOtrPayload aliceClient rcpts "" MismatchReportAll + msr = + FedGalley.ProteusMessageSendRequest + { FedGalley.pmsrConvId = convId, + FedGalley.pmsrSender = aliceId, + FedGalley.pmsrRawMessage = Base64ByteString (Protolens.encodeMessage msg) + } + let mock = do + guardComponent Brig + mockReply (mempty :: Map (Id a) (Set PubClient)) + -- Use a documentation reserved IP address for the endpoint so we can be sure it isn't going + -- to successfully return anything + (_, requests2) <- withTempMockFederatorWithEndpointIP "192.0.2.0" (mock <|> mockReply ()) $ do + WS.bracketR cannon bobId $ \ws -> do + -- Override the timeout settings for http requests. + -- We are expecting this to fail, so failing quickly + -- would be nice. Setting the value to 5 seconds + tlsManager <- liftIO $ newManager tlsManagerSettings {managerResponseTimeout = responseTimeoutMicro 5000000} + msresp <- local (set tsManager tlsManager) $ do + g <- viewGalley + post + ( g + . paths ["federation", "send-message"] + . content "application/json" + . header "Wire-Origin-Domain" (toByteString' localDomain) + . json msr + ) + assertFailure $ "Expected Right, got Left: " <> show err + Right mss -> do + assertEqual "missing clients should be empty" mempty (mssMissingClients mss) + assertEqual "redundant clients should be empty" mempty (mssRedundantClients mss) + assertEqual "deleted clients should be empty" mempty (mssDeletedClients mss) + -- Alice should receive the list of clients that messages couldn't be sent to in this case, bob. + assertEqual + "failed to send should contain bob" + (QualifiedUserClients $ Map.singleton remoteDomain $ Map.singleton bobId mempty) + (mssFailedToSend mss) + + -- check that bob did not received the message + WS.assertNoEvent (5 # Second) $ pure ws + + -- check that a request to propagate message to bob has not been made + liftIO $ + case requests2 of + [] -> pure () + _ -> assertFailure "unexpected number of requests" + -- | There are 3 backends in action here: -- -- - Backend A (local) has Alice and Alex diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index c2db9ef395e..e74ec1307b9 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -2577,7 +2577,18 @@ withTempMockFederator' :: Mock LByteString -> m b -> m (b, [FederatedRequest]) -withTempMockFederator' resp action = do +withTempMockFederator' = withTempMockFederatorWithEndpointIP "127.0.0.1" + +-- Allow a test to specify an endpoint IP +-- This is useful for mocking servers that +-- are unreachable +withTempMockFederatorWithEndpointIP :: + (MonadIO m, MonadMask m, HasSettingsOverrides m) => + Text -> + Mock LByteString -> + m b -> + m (b, [FederatedRequest]) +withTempMockFederatorWithEndpointIP endpoint resp action = do let mock = runMock (assertFailure . Text.unpack) $ do r <- resp pure ("application" // "json", r) @@ -2585,7 +2596,7 @@ withTempMockFederator' resp action = do [("Content-Type", "application/json")] mock $ \mockPort -> do - withSettingsOverrides (\opts -> opts & Opts.optFederator ?~ Endpoint "127.0.0.1" (fromIntegral mockPort)) action + withSettingsOverrides (\opts -> opts & Opts.optFederator ?~ Endpoint endpoint (fromIntegral mockPort)) action -- Starts a servant Application in Network.Wai.Test session and runs the -- FederatedRequest against it. From 96e3a461e5f646f1be67e5070bf3e17c8d2ccd41 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Fri, 24 Feb 2023 13:41:17 +1000 Subject: [PATCH 02/10] testing changes. Reworking how failing federators are tested. Rewriting the test, basing it off an existing test that is almost what is needed, and removing the prior test. --- services/galley/src/Galley/API/Message.hs | 16 ++- services/galley/test/integration/API.hs | 80 ++++++++++++++ .../galley/test/integration/API/Federation.hs | 100 +----------------- 3 files changed, 88 insertions(+), 108 deletions(-) diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index d9aa51d2cda..57418a30ecd 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -438,7 +438,6 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = 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 @@ -485,21 +484,19 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = -- 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, _)) = none (\(d', (u', _)) -> d == d' && u == u') failed' - (redundant, redundantFailed) = partition predicate redundant' + predicate (d, (u, _)) = any (\(d', (u', _)) -> d == d' && u == u') failed' + redundantFailed = filter predicate redundant' pure otrResult { mssFailedToSend = QualifiedUserClients $ foldr - (Map.unionWith (Map.unionWith (<>))) + (Map.unionWith (Map.unionWith Set.union)) mempty [ qualifiedUserClients failedToSend, qualifiedUserClients failedToSendFetchingClients, fromDomUserClient redundantFailed - ], - mssRedundantClients = - QualifiedUserClients $ fromDomUserClient redundant + ] } where -- Get the triples for domains, users, and clients so we can easily filter @@ -512,8 +509,9 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = fromDomUserClient :: [(Domain, (UserId, Set ClientId))] -> Map Domain (Map UserId (Set ClientId)) fromDomUserClient = foldr f mempty where - f (d, (u, c)) = Map.update (pure . Map.update (g c) u) d - g c = pure . mappend c + 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) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 7e2bf342769..ff2e6522e44 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 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) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 7f202ad7552..39c03e7feec 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -42,8 +42,6 @@ import Data.Timeout (TimeoutUnit (..), (#)) import Data.UUID.V4 (nextRandom) import Federator.MockServer import Imports -import Network.HTTP.Client -import Network.HTTP.Client.TLS import Test.QuickCheck (arbitrary, generate) import Test.Tasty import qualified Test.Tasty.Cannon as WS @@ -61,7 +59,7 @@ import Wire.API.Federation.Component import Wire.API.Internal.Notification import Wire.API.Message import Wire.API.Routes.Internal.Galley.ConversationsIntra -import Wire.API.User.Client (PubClient (..), QualifiedUserClients (..)) +import Wire.API.User.Client (PubClient (..)) import Wire.API.User.Profile tests :: IO TestSetup -> TestTree @@ -87,7 +85,6 @@ tests s = test s "POST /federation/leave-conversation : Invalid type" leaveConversationInvalidType, test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent, test s "POST /federation/send-message : Post a message sent from another backend" sendMessage, - test s "POST /federation/send-message : Ensure that messages are send when some backends are unavailable" sendMessageUnavailableFederation, test s "POST /federation/on-user-deleted-conversations : Remove deleted remote user from local conversations" onUserDeleted, test s "POST /federation/update-conversation : Update local conversation by a remote admin " updateConversationByRemoteAdmin ] @@ -921,101 +918,6 @@ sendMessage = do Map.keysSet (userClientMap (FedGalley.rmRecipients rm)) @?= Set.singleton chadId --- alice local, bob and chad remote in a local conversation --- alice sends a message, we test that alice receieves a list of clients --- that the message wasn't sent to and that a call is made to the --- onMessageSent RPC to inform chad --- Reporting ticket: FS-51 -sendMessageUnavailableFederation :: TestM () -sendMessageUnavailableFederation = do - cannon <- view tsCannon - let remoteDomain = Domain "far-away.example.com" - localDomain <- viewFederationDomain - - -- users and clients - (alice, aliceClient) <- randomUserWithClientQualified (head someLastPrekeys) - let aliceId = qUnqualified alice - bobId <- randomId - bobClient <- liftIO $ generate arbitrary - let bob = Qualified bobId remoteDomain - bobProfile = mkProfile bob (Name "Bob") - connectWithRemoteUser aliceId bob - -- conversation - let responses1 = guardComponent Brig *> mockReply [bobProfile] - - (convId, requests1) <- - withTempMockFederator' (responses1 <|> mockReply ()) $ - fmap decodeConvId $ - postConvQualified - aliceId - defNewProteusConv - { newConvQualifiedUsers = [bob] - } - pure xs - _ -> assertFailure "unexpected number of requests" - frComponent galleyReq @?= Galley - frRPC galleyReq @?= "on-conversation-created" - - -- we use bilge instead of the federation client to make a federated request - -- here, because we need to make use of the mock federator, which at the moment - -- supports only bilge requests - let rcpts = - [ (bob, bobClient, "hi bob") - ] - msg = mkQualifiedOtrPayload aliceClient rcpts "" MismatchReportAll - msr = - FedGalley.ProteusMessageSendRequest - { FedGalley.pmsrConvId = convId, - FedGalley.pmsrSender = aliceId, - FedGalley.pmsrRawMessage = Base64ByteString (Protolens.encodeMessage msg) - } - let mock = do - guardComponent Brig - mockReply (mempty :: Map (Id a) (Set PubClient)) - -- Use a documentation reserved IP address for the endpoint so we can be sure it isn't going - -- to successfully return anything - (_, requests2) <- withTempMockFederatorWithEndpointIP "192.0.2.0" (mock <|> mockReply ()) $ do - WS.bracketR cannon bobId $ \ws -> do - -- Override the timeout settings for http requests. - -- We are expecting this to fail, so failing quickly - -- would be nice. Setting the value to 5 seconds - tlsManager <- liftIO $ newManager tlsManagerSettings {managerResponseTimeout = responseTimeoutMicro 5000000} - msresp <- local (set tsManager tlsManager) $ do - g <- viewGalley - post - ( g - . paths ["federation", "send-message"] - . content "application/json" - . header "Wire-Origin-Domain" (toByteString' localDomain) - . json msr - ) - assertFailure $ "Expected Right, got Left: " <> show err - Right mss -> do - assertEqual "missing clients should be empty" mempty (mssMissingClients mss) - assertEqual "redundant clients should be empty" mempty (mssRedundantClients mss) - assertEqual "deleted clients should be empty" mempty (mssDeletedClients mss) - -- Alice should receive the list of clients that messages couldn't be sent to in this case, bob. - assertEqual - "failed to send should contain bob" - (QualifiedUserClients $ Map.singleton remoteDomain $ Map.singleton bobId mempty) - (mssFailedToSend mss) - - -- check that bob did not received the message - WS.assertNoEvent (5 # Second) $ pure ws - - -- check that a request to propagate message to bob has not been made - liftIO $ - case requests2 of - [] -> pure () - _ -> assertFailure "unexpected number of requests" - -- | There are 3 backends in action here: -- -- - Backend A (local) has Alice and Alex From 90d6bc49dfa617b0fe98d6ba2844b7fec2507b6f Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Wed, 1 Mar 2023 18:36:44 +1000 Subject: [PATCH 03/10] FS-51: Adding changes from PR review and more tests --- services/galley/galley.cabal | 1 + services/galley/src/Galley/API/Message.hs | 30 +++---- services/galley/test/integration/API.hs | 97 +++++++++++++++++++---- 3 files changed, 98 insertions(+), 30 deletions(-) diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 458fa0ecd4d..e72455b0eeb 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 diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index c71316d0623..5092d93130e 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 @@ -437,7 +438,7 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = extractUserMap l = Map.singleton domain $ Map.fromList $ (,mempty) <$> users where domain = qDomain $ tUntagged l - users = qUnqualified $ tUntagged l + users = tUnqualified l -- check if the sender client exists (as one of the clients in the conversation) unless ( Set.member @@ -488,15 +489,11 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = redundantFailed = filter predicate redundant' pure otrResult - { mssFailedToSend = - QualifiedUserClients $ - foldr - (Map.unionWith (Map.unionWith Set.union)) - mempty - [ qualifiedUserClients failedToSend, - qualifiedUserClients failedToSendFetchingClients, - fromDomUserClient redundantFailed - ] + { mssFailedToSend = QualifiedUserClients $ collectFailedToSend + [ qualifiedUserClients failedToSend, + qualifiedUserClients failedToSendFetchingClients, + fromDomUserClient redundantFailed + ] } where -- Get the triples for domains, users, and clients so we can easily filter @@ -507,11 +504,16 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = (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 + fromDomUserClient = foldr buildUserClientMap 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 + 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 c2297401913..9b909b87061 100644 --- a/services/galley/test/integration/API.hs +++ b/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,7 +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 send clients 2" postMessageQualifiedLocalOwningBackendFailedToSendClients2, + 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, @@ -1151,8 +1154,8 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients = do -- This test is similar to postMessageQualifiedLocalOwningBackendFailedToSendClients -- except that both of the calls to the federated server are failing. -postMessageQualifiedLocalOwningBackendFailedToSendClients2 :: TestM () -postMessageQualifiedLocalOwningBackendFailedToSendClients2 = do +postMessageQualifiedLocalOwningBackendFailedToSendClientsFailingGetUserClients :: TestM () +postMessageQualifiedLocalOwningBackendFailedToSendClientsFailingGetUserClients = do -- WS receive timeout let t = 5 # Second -- Cannon for local users @@ -1166,8 +1169,12 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients2 = do (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 @@ -1175,12 +1182,13 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients2 = do 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]} + defNewProteusConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote, emilyRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do @@ -1188,12 +1196,21 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients2 = do [ (bobOwningDomain, bobClient, "text-for-bob"), (bobOwningDomain, bobClient2, "text-for-bob2"), (chadOwningDomain, chadClient, "text-for-chad"), - (deeRemote, deeClient, "text-for-dee") + (deeRemote, deeClient, "text-for-dee"), + (emilyRemote, emilyClient, "text-for-emily") ] let mock = - ( guardRPC "get-user-clients" - *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.") + ( 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.") @@ -1209,15 +1226,25 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients2 = do "data" Message.MismatchReportAll - let expectedFailedToSend = - QualifiedUserClients . Map.fromList $ - [ ( remoteDomain, - Map.fromList - [ (deeId, Set.singleton deeClient) - ] - ) - ] - expectedRedundant = expectedFailedToSend + let expectedFailedToSend = QualifiedUserClients . Map.fromList $ + [ ( remoteDomain, + Map.fromList + [ (deeId, Set.singleton deeClient) + ] + ) + , ( remoteDomain2, + Map.fromList + [ (emilyId, Set.singleton emilyClient) + ] + ) + ] + expectedRedundant = QualifiedUserClients . Map.fromList $ + [ ( remoteDomain, + Map.fromList + [ (deeId, Set.singleton deeClient) + ] + ) + ] pure resp2 !!! do const 201 === statusCode assertMismatchQualified expectedFailedToSend mempty expectedRedundant mempty @@ -1229,6 +1256,44 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients2 = do 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) From 32099331779b6c3c75a48e377dcaa6498f6181d4 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Fri, 3 Mar 2023 14:48:18 +1000 Subject: [PATCH 04/10] Updating tests --- services/galley/src/Galley/API/Message.hs | 6 ++++-- services/galley/test/integration/API.hs | 9 +-------- 2 files changed, 5 insertions(+), 10 deletions(-) diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 5092d93130e..3c3e617e5b0 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -486,14 +486,16 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = -- 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' + -- Failed users/clients aren't redundant + (failed, redundant) = partition predicate redundant' pure otrResult { mssFailedToSend = QualifiedUserClients $ collectFailedToSend [ qualifiedUserClients failedToSend, qualifiedUserClients failedToSendFetchingClients, - fromDomUserClient redundantFailed + fromDomUserClient failed ] + , mssRedundantClients = QualifiedUserClients $ fromDomUserClient redundant } where -- Get the triples for domains, users, and clients so we can easily filter diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 9b909b87061..b6931ef7348 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1238,16 +1238,9 @@ postMessageQualifiedLocalOwningBackendFailedToSendClientsFailingGetUserClients = ] ) ] - expectedRedundant = QualifiedUserClients . Map.fromList $ - [ ( remoteDomain, - Map.fromList - [ (deeId, Set.singleton deeClient) - ] - ) - ] pure resp2 !!! do const 201 === statusCode - assertMismatchQualified expectedFailedToSend mempty expectedRedundant mempty + assertMismatchQualified expectedFailedToSend mempty mempty mempty liftIO $ do let encodedTextForBob = toBase64Text "text-for-bob" From cb9182478c760c9c5f5a2577413e24ef6698ad47 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Wed, 8 Mar 2023 13:59:59 +1000 Subject: [PATCH 05/10] FS-51: Moving unit tests to a better module --- services/galley/galley.cabal | 1 + services/galley/test/integration/API.hs | 51 +----------------- .../test/unit/Test/Galley/API/Message.hs | 54 ++++++++++++++++++- 3 files changed, 54 insertions(+), 52 deletions(-) diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 5b90fc0c479..4e94167b012 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -860,6 +860,7 @@ test-suite galley-tests , tasty-quickcheck , transformers , types-common + , uuid-types , wai , wai-predicates , wire-api diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index a8aab48ea1e..f0e09e2eff5 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -62,11 +62,9 @@ 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 @@ -223,7 +221,7 @@ tests s = 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, @@ -1248,53 +1246,6 @@ postMessageQualifiedLocalOwningBackendFailedToSendClientsFailingGetUserClients = 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) diff --git a/services/galley/test/unit/Test/Galley/API/Message.hs b/services/galley/test/unit/Test/Galley/API/Message.hs index e2b0f63e27a..a2cd49d796c 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 @@ -41,6 +42,7 @@ tests = checkMessageClientRedundantSender, checkMessageClientMissingSubsetOfStrategy ] + , testBuildFailedToSend ] flatten :: Map Domain (Map UserId (Set ClientId)) -> Set (Domain, UserId, ClientId) @@ -100,3 +102,51 @@ 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" \ No newline at end of file From 175fbfb63e2866085ce24e8d0cb7606842dd21da Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Wed, 8 Mar 2023 14:29:46 +1000 Subject: [PATCH 06/10] FS-51: Formatting and linters --- services/galley/test/integration/API.hs | 1 - .../test/unit/Test/Galley/API/Message.hs | 94 ++++++++++--------- 2 files changed, 48 insertions(+), 47 deletions(-) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index b2a701128ec..480c0583c91 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -221,7 +221,6 @@ tests s = 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, diff --git a/services/galley/test/unit/Test/Galley/API/Message.hs b/services/galley/test/unit/Test/Galley/API/Message.hs index a2cd49d796c..25575bdcb1f 100644 --- a/services/galley/test/unit/Test/Galley/API/Message.hs +++ b/services/galley/test/unit/Test/Galley/API/Message.hs @@ -41,8 +41,8 @@ tests = checkMessageClientEverythingReported, checkMessageClientRedundantSender, checkMessageClientMissingSubsetOfStrategy - ] - , testBuildFailedToSend + ], + testBuildFailedToSend ] flatten :: Map Domain (Map UserId (Set ClientId)) -> Set (Domain, UserId, ClientId) @@ -104,49 +104,51 @@ checkMessageClientMissingSubsetOfStrategy = testProperty "missing clients should 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) - ] - ) - ] +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" \ No newline at end of file + idB = Id $ fromJust $ Data.UUID.Types.fromString "bbbbbbbb-bbbb-bbbb-bbbb-bbbbbbbbbbbb" From 47cafd29ae219308fb22871c9edc46c0768f06b0 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Wed, 8 Mar 2023 19:54:32 +1000 Subject: [PATCH 07/10] FS-51: Updating nix with generate-local-nix-packages.sh --- services/galley/default.nix | 3 +++ 1 file changed, 3 insertions(+) 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 From 752e1f55f4a1da46262cf034c1769187adcc3536 Mon Sep 17 00:00:00 2001 From: Owen Harvey Date: Wed, 8 Mar 2023 20:42:28 +1000 Subject: [PATCH 08/10] FS-51: Fixing an error --- services/galley/test/integration/API.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 480c0583c91..ff5dd1b6a54 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1188,6 +1188,7 @@ postMessageQualifiedLocalOwningBackendFailedToSendClientsFailingGetUserClients = resp <- postConvWithRemoteUsers aliceUnqualified + Nothing defNewProteusConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote, emilyRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp From 3b95fb5f2cdd25883b44a70a202a4d5a410dce77 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 8 Mar 2023 13:12:38 +0100 Subject: [PATCH 09/10] Hi CI From eab18a6428170f8dbca3684edbb96c702eabd3b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 9 Mar 2023 14:04:45 +0100 Subject: [PATCH 10/10] Hi CI