diff --git a/CHANGELOG.md b/CHANGELOG.md index ef94f0dfc02..cc1163effc2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -23,6 +23,7 @@ ## Features * [Federation] (Not-yet-used) RPC to propagate messages to other backends (#1596). +* [Federation] Fetch remote user's clients when sending messages (#1635). ## Internal changes diff --git a/libs/bilge/src/Bilge/Assert.hs b/libs/bilge/src/Bilge/Assert.hs index 670d20b19e5..eff19553a31 100644 --- a/libs/bilge/src/Bilge/Assert.hs +++ b/libs/bilge/src/Bilge/Assert.hs @@ -26,6 +26,7 @@ module Bilge.Assert (===), (=/=), (=~=), + assertResponse, assertTrue, assertTrue_, assert, @@ -140,6 +141,11 @@ f =/= g = Assertions $ tell [\r -> test " === " (/=) (f r) (g r)] Assertions () f =~= g = Assertions $ tell [\r -> test " not in " contains (f r) (g r)] +-- | Most generic assertion on a request. If the test function evaluates to +-- @(Just msg)@ then the assertion fails with the error message @msg@. +assertResponse :: HasCallStack => (Response (Maybe Lazy.ByteString) -> Maybe String) -> Assertions () +assertResponse f = Assertions $ tell [f] + -- | Generic assertion on a request. The 'String' argument will be printed -- in case the assertion fails. assertTrue :: HasCallStack => String -> (Response (Maybe Lazy.ByteString) -> Bool) -> Assertions () diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 5835e80a100..ceb0ee54e7b 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -8,13 +8,13 @@ import Data.List1 (singleton) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) import Data.Proxy -import Data.Qualified (Qualified (..)) +import Data.Qualified (Qualified (..), partitionRemote) import Data.SOP (I (..), htrans, unI) import qualified Data.Set as Set import Data.Set.Lens import Data.Time.Clock (UTCTime, getCurrentTime) import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) -import Galley.API.Util (runUnionT, throwUnion, viewFederationDomain) +import Galley.API.Util (runFederatedBrig, runUnionT, throwUnion, viewFederationDomain) import Galley.App import qualified Galley.Data as Data import Galley.Data.Services as Data @@ -28,13 +28,16 @@ import Galley.Types.Conversations.Members import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports import Servant.API (Union, WithStatus (..)) +import UnliftIO.Async import Wire.API.ErrorDescription as ErrorDescription import Wire.API.Event.Conversation +import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Message import qualified Wire.API.Message as Public import Wire.API.Routes.Public.Galley as Public import Wire.API.Team.LegalHold import Wire.API.User.Client +import Wire.API.UserMap (UserMap (..)) data UserType = User | Bot @@ -144,6 +147,20 @@ checkMessageClients sender participantMap recipientMap mismatchStrat = mkQualifiedMismatch reportedMissing redundant deleted ) +getRemoteClients :: ConvId -> Galley (Map (Domain, UserId) (Set ClientId)) +getRemoteClients convId = do + remoteMembers <- Data.lookupRemoteMembers convId + fmap mconcat -- concatenating maps is correct here, because their sets of keys are disjoint + . pooledMapConcurrentlyN 8 (uncurry getRemoteClientsFromDomain) + . partitionRemote + . map rmId + $ remoteMembers + where + getRemoteClientsFromDomain :: Domain -> [UserId] -> Galley (Map (Domain, UserId) (Set ClientId)) + getRemoteClientsFromDomain domain uids = do + let rpc = FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) + Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap <$> runFederatedBrig domain rpc + postQualifiedOtrMessage :: UserType -> UserId -> Maybe ConnId -> ConvId -> Public.QualifiedNewOtrMessage -> Galley (Union Public.PostOtrResponses) postQualifiedOtrMessage senderType sender mconn convId msg = runUnionT $ do alive <- Data.isConvAlive convId @@ -157,6 +174,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runUnionT $ do Data.deleteConversation convId throwUnion ErrorDescription.convNotFound + -- get local clients localMembers <- Data.members convId let localMemberIds = memId <$> localMembers localMemberMap :: Map UserId LocalMember @@ -183,10 +201,12 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runUnionT $ do unless (Set.member senderClient (Map.findWithDefault mempty (senderDomain, sender) qualifiedLocalClients)) $ do throwUnion ErrorDescription.unknownClient + qualifiedRemoteClients <- lift $ getRemoteClients convId + let (sendMessage, validMessages, mismatch) = checkMessageClients (senderDomain, sender, qualifiedNewOtrSender msg) - qualifiedLocalClients + (qualifiedLocalClients <> qualifiedRemoteClients) (flattenMap $ qualifiedNewOtrRecipients msg) (qualifiedNewOtrClientMismatchStrategy msg) otrResult = mkMessageSendingStatus nowMillis mismatch mempty diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index a47c20893f6..d980f4e2b94 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -83,6 +83,7 @@ module Galley.Data addLocalMembersToRemoteConv, member, members, + lookupRemoteMembers, removeMember, removeMembers, removeLocalMembers, diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 0faf49359fc..b93840799c5 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -52,6 +52,7 @@ import qualified Data.Map.Strict as Map import Data.Qualified import Data.Range import qualified Data.Set as Set +import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.Text.Ascii as Ascii import qualified Galley.Data as Cql @@ -71,10 +72,12 @@ import TestHelpers import TestSetup import Util.Options (Endpoint (Endpoint)) import Wire.API.Conversation +import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Federation.API.Galley (GetConversationsResponse (..)) import qualified Wire.API.Federation.GRPC.Types as F import qualified Wire.API.Message as Message import Wire.API.User.Client (QualifiedUserClients (..), UserClientPrekeyMap, getUserClientPrekeyMap) +import Wire.API.UserMap (UserMap (..)) tests :: IO TestSetup -> TestTree tests s = @@ -240,13 +243,13 @@ postCryptoMessage1 = do let m1 = [(bob, bc, "ciphertext1")] postOtrMessage id alice ac conv m1 !!! do const 412 === statusCode - assertTrue_ (eqMismatch [(eve, Set.singleton ec)] [] [] . responseJsonUnsafe) + assertMismatch [(eve, Set.singleton ec)] [] [] -- Complete WS.bracketR2 c bob eve $ \(wsB, wsE) -> do let m2 = [(bob, bc, toBase64Text "ciphertext2"), (eve, ec, toBase64Text "ciphertext2")] postOtrMessage id alice ac conv m2 !!! do const 201 === statusCode - assertTrue_ (eqMismatch [] [] [] . responseJsonUnsafe) + assertMismatch [] [] [] void . liftIO $ WS.assertMatch t wsB (wsAssertOtr qconv qalice ac bc (toBase64Text "ciphertext2")) void . liftIO $ WS.assertMatch t wsE (wsAssertOtr qconv qalice ac ec (toBase64Text "ciphertext2")) -- Redundant self @@ -254,7 +257,7 @@ postCryptoMessage1 = do let m3 = [(alice, ac, toBase64Text "ciphertext3"), (bob, bc, toBase64Text "ciphertext3"), (eve, ec, toBase64Text "ciphertext3")] postOtrMessage id alice ac conv m3 !!! do const 201 === statusCode - assertTrue_ (eqMismatch [] [(alice, Set.singleton ac)] [] . responseJsonUnsafe) + assertMismatch [] [(alice, Set.singleton ac)] [] void . liftIO $ WS.assertMatch t wsB (wsAssertOtr qconv qalice ac bc (toBase64Text "ciphertext3")) void . liftIO $ WS.assertMatch t wsE (wsAssertOtr qconv qalice ac ec (toBase64Text "ciphertext3")) -- Alice should not get it @@ -265,7 +268,7 @@ postCryptoMessage1 = do let m4 = [(bob, bc, toBase64Text "ciphertext4"), (eve, ec, toBase64Text "ciphertext4")] postOtrMessage id alice ac conv m4 !!! do const 201 === statusCode - assertTrue_ (eqMismatch [] [] [(eve, Set.singleton ec)] . responseJsonUnsafe) + assertMismatch [] [] [(eve, Set.singleton ec)] void . liftIO $ WS.assertMatch t wsB (wsAssertOtr qconv qalice ac bc (toBase64Text "ciphertext4")) -- Eve should not get it assertNoMsg wsE (wsAssertOtr qconv qalice ac ec (toBase64Text "ciphertext4")) @@ -274,7 +277,7 @@ postCryptoMessage1 = do let m5 = [(bob, bc, toBase64Text "ciphertext5"), (eve, ec, toBase64Text "ciphertext5"), (alice, ac, toBase64Text "ciphertext5")] postOtrMessage id alice ac conv m5 !!! do const 201 === statusCode - assertTrue_ (eqMismatch [] [(alice, Set.singleton ac)] [(eve, Set.singleton ec)] . responseJsonUnsafe) + assertMismatch [] [(alice, Set.singleton ac)] [(eve, Set.singleton ec)] void . liftIO $ WS.assertMatch t wsB (wsAssertOtr qconv qalice ac bc (toBase64Text "ciphertext5")) -- Neither Alice nor Eve should get it assertNoMsg wsA (wsAssertOtr qconv qalice ac ac (toBase64Text "ciphertext5")) @@ -283,13 +286,10 @@ postCryptoMessage1 = do let m6 = [(eve, ec, toBase64Text "ciphertext6"), (alice, ac, toBase64Text "ciphertext6")] postOtrMessage id alice ac conv m6 !!! do const 412 === statusCode - assertTrue_ - ( eqMismatch - [(bob, Set.singleton bc)] - [(alice, Set.singleton ac)] - [(eve, Set.singleton ec)] - . responseJsonUnsafe - ) + assertMismatch + [(bob, Set.singleton bc)] + [(alice, Set.singleton ac)] + [(eve, Set.singleton ec)] -- A second client for Bob bc2 <- randomClient bob (someLastPrekeys !! 3) -- The first client listens for all messages of Bob @@ -300,7 +300,7 @@ postCryptoMessage1 = do let m7 = [(bob, bc, cipher), (bob, bc2, cipher)] postOtrMessage id alice ac conv m7 !!! do const 201 === statusCode - assertTrue_ (eqMismatch [] [] [] . responseJsonUnsafe) + assertMismatch [] [] [] -- Bob's first client gets both messages void . liftIO $ WS.assertMatch t wsB (wsAssertOtr qconv qalice ac bc cipher) void . liftIO $ WS.assertMatch t wsB (wsAssertOtr qconv qalice ac bc2 cipher) @@ -321,10 +321,10 @@ postCryptoMessage2 = do -- Missing eve let m = [(bob, bc, toBase64Text "hello bob")] r1 <- - postOtrMessage id alice ac conv m - do - postProteusMessageQualified aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll !!! do + let responses _ = UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) + (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll responses + + pure resp2 !!! do const 412 === statusCode let expectedMissing = QualifiedUserClients $ Map.fromList [ ( owningDomain, - Map.fromList $ + Map.fromList [ (bobUnqualified, Set.singleton bobClient), (chadUnqualified, Set.singleton chadClient2) ] + ), + ( remoteDomain, + Map.singleton (qUnqualified deeRemote) (Set.singleton deeClient) ) ] - assertTrue_ (eqMismatchQualified expectedMissing mempty mempty . responseJsonMaybe) + assertMismatchQualified expectedMissing mempty mempty WS.assertNoEvent (1 # Second) [wsBob, wsChad] -- | Sets up a conversation on Backend A known as "owning backend". One of the @@ -555,7 +578,9 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do let aliceUnqualified = qUnqualified aliceOwningDomain bobUnqualified = qUnqualified bobOwningDomain chadUnqualified = qUnqualified chadOwningDomain + deeRemoteUnqualified = qUnqualified deeRemote nonMemberUnqualified = qUnqualified nonMemberOwningDomain + nonMemberRemoteUnqualified = qUnqualified nonMemberRemote connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) @@ -572,17 +597,44 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do (nonMemberOwningDomain, nonMemberOwningDomainClient, "text-for-non-member-owning-domain"), (nonMemberRemote, nonMemberRemoteClient, "text-for-non-member-remote") ] - -- FUTUREWORK: Mock federator and ensure that a message to Dee is sent and - -- nonParticipatingRemote is reported as redundant - postProteusMessageQualified aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll !!! do + -- FUTUREWORK: Mock federator and ensure that a message to Dee is sent + + let responses fedRequest = + let request = fromMaybe (error "no request") $ F.request fedRequest + lookupClients uid + | uid == deeRemoteUnqualified = Just (uid, [PubClient deeClient Nothing]) + | uid == nonMemberRemoteUnqualified = Just (uid, [PubClient nonMemberRemoteClient Nothing]) + | otherwise = Nothing + in case F.path request of + "/federation/get-user-clients" -> + let (getUserClients :: FederatedBrig.GetUserClients) = fromMaybe (error "parsing GetUserClients") $ decode (cs . F.body $ request) + in UserMap + . Map.fromList + . mapMaybe lookupClients + . FederatedBrig.gucUsers + $ getUserClients + _ -> error ("unmocked request: " <> show request) + + (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll responses + pure resp2 !!! do const 201 === statusCode let expectedRedundant = - QualifiedUserClients . Map.singleton owningDomain . Map.fromList $ - [(nonMemberUnqualified, Set.singleton nonMemberOwningDomainClient)] + QualifiedUserClients . Map.fromList $ + [ ( owningDomain, + Map.fromList $ + [ (nonMemberUnqualified, Set.singleton nonMemberOwningDomainClient) + ] + ), + ( remoteDomain, + Map.fromList $ + [ (nonMemberRemoteUnqualified, Set.singleton nonMemberRemoteClient) + ] + ) + ] expectedDeleted = QualifiedUserClients . Map.singleton owningDomain . Map.fromList $ [(chadUnqualified, Set.singleton chadClientNonExistent)] - assertTrue_ (eqMismatchQualified mempty expectedRedundant expectedDeleted . responseJsonMaybe) + assertMismatchQualified mempty expectedRedundant expectedDeleted liftIO $ do let encodedTextForBob = toBase64Text "text-for-bob" encodedTextForChad = toBase64Text "text-for-chad" @@ -610,6 +662,8 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do (chadOwningDomain, chadClient) <- randomUserWithClientQualified (someLastPrekeys !! 3) chadClient2 <- randomClient (qUnqualified chadOwningDomain) (someLastPrekeys !! 2) deeId <- randomId + deeClient <- liftIO $ generate arbitrary + let remoteDomain = Domain "far-away.example.com" deeRemote = Qualified deeId remoteDomain @@ -622,15 +676,17 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do -- FUTUREWORK: Do this test with more than one remote domains resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] let convId = (`Qualified` owningDomain) . decodeConvId $ resp + responses _ = UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) -- Missing Bob, chadClient2 and Dee let message = [(chadOwningDomain, chadClient, "text-for-chad")] -- FUTUREWORK: Mock federator and ensure that clients of Dee are checked. Also -- ensure that message is not propagated to remotes WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do - postProteusMessageQualified aliceUnqualified aliceClient convId message "data" Message.MismatchIgnoreAll !!! do + (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchIgnoreAll responses + pure resp2 !!! do const 201 === statusCode - assertTrue_ (eqMismatchQualified mempty mempty mempty . responseJsonMaybe) + assertMismatchQualified mempty mempty mempty let encodedTextForChad = toBase64Text "text-for-chad" encodedData = toBase64Text "data" WS.assertMatch_ t wsChad (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient chadClient encodedTextForChad) @@ -638,9 +694,10 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do -- Another way to ignore all is to report nobody WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do - postProteusMessageQualified aliceUnqualified aliceClient convId message "data" (Message.MismatchReportOnly mempty) !!! do + (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" (Message.MismatchReportOnly mempty) responses + pure resp2 !!! do const 201 === statusCode - assertTrue_ (eqMismatchQualified mempty mempty mempty . responseJsonMaybe) + assertMismatchQualified mempty mempty mempty let encodedTextForChad = toBase64Text "text-for-chad" encodedData = toBase64Text "data" WS.assertMatch_ t wsChad (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient chadClient encodedTextForChad) @@ -648,9 +705,18 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do -- Yet another way to ignore all is to ignore specific users WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do - postProteusMessageQualified aliceUnqualified aliceClient convId message "data" (Message.MismatchIgnoreOnly (Set.fromList [bobOwningDomain, chadOwningDomain, deeRemote])) !!! do + (resp2, _requests) <- + postProteusMessageQualifiedWithMockFederator + aliceUnqualified + aliceClient + convId + message + "data" + (Message.MismatchIgnoreOnly (Set.fromList [bobOwningDomain, chadOwningDomain, deeRemote])) + responses + pure resp2 !!! do const 201 === statusCode - assertTrue_ (eqMismatchQualified mempty mempty mempty . responseJsonMaybe) + assertMismatchQualified mempty mempty mempty let encodedTextForChad = toBase64Text "text-for-chad" encodedData = toBase64Text "data" WS.assertMatch_ t wsChad (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient chadClient encodedTextForChad) @@ -659,12 +725,40 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do -- When we ask only chad be reported, but one of their clients is missing, the -- message shouldn't be sent! WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do - postProteusMessageQualified aliceUnqualified aliceClient convId message "data" (Message.MismatchReportOnly (Set.fromList [chadOwningDomain])) !!! do + (resp2, _requests) <- + postProteusMessageQualifiedWithMockFederator + aliceUnqualified + aliceClient + convId + message + "data" + (Message.MismatchReportOnly (Set.fromList [chadOwningDomain])) + responses + pure resp2 !!! do const 412 === statusCode let expectedMissing = QualifiedUserClients . Map.singleton owningDomain . Map.fromList $ [(chadUnqualified, Set.singleton chadClient2)] - assertTrue_ (eqMismatchQualified expectedMissing mempty mempty . responseJsonMaybe) + assertMismatchQualified expectedMissing mempty mempty + WS.assertNoEvent (1 # Second) [wsBob, wsChad] + + -- Same as above, but with a remote user's client + WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do + (resp2, _requests) <- + postProteusMessageQualifiedWithMockFederator + aliceUnqualified + aliceClient + convId + message + "data" + (Message.MismatchReportOnly (Set.fromList [deeRemote])) + responses + pure resp2 !!! do + const 412 === statusCode + let expectedMissing = + QualifiedUserClients . Map.singleton remoteDomain . Map.fromList $ + [(qUnqualified deeRemote, Set.singleton deeClient)] + assertMismatchQualified expectedMissing mempty mempty WS.assertNoEvent (1 # Second) [wsBob, wsChad] postMessageQualifiedRemoteOwningBackendNotImplemented :: TestM () @@ -877,9 +971,9 @@ getConvsOk2 = do const (Just [cnvId cnv2]) === fmap (map cnvId . convList) . responseJsonUnsafe -- get both rs <- getConvs alice Nothing Nothing responseJsonUnsafe rs - let c1 = cs >>= find ((== cnvId cnv1) . cnvId) - let c2 = cs >>= find ((== cnvId cnv2) . cnvId) + let convs = convList <$> responseJsonUnsafe rs + let c1 = convs >>= find ((== cnvId cnv1) . cnvId) + let c2 = convs >>= find ((== cnvId cnv2) . cnvId) liftIO . forM_ [(cnv1, c1), (cnv2, c2)] $ \(expected, actual) -> do assertEqual "name mismatch" @@ -916,9 +1010,9 @@ listConvsOk2 = do const (Just [cnvId cnv2]) === fmap (map cnvId . convList) . responseJsonUnsafe -- get both rs <- listAllConvs alice responseJsonUnsafe rs - let c1 = cs >>= find ((== cnvId cnv1) . cnvId) - let c2 = cs >>= find ((== cnvId cnv2) . cnvId) + let convs = convList <$> responseJsonUnsafe rs + let c1 = convs >>= find ((== cnvId cnv1) . cnvId) + let c2 = convs >>= find ((== cnvId cnv2) . cnvId) liftIO . forM_ [(cnv1, c1), (cnv2, c2)] $ \(expected, actual) -> do assertEqual "name mismatch" diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 040854abbd6..489e7c239b0 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1682,7 +1682,7 @@ postCryptoBroadcastMessageJson = do WS.bracketR (c . queryItem "client" (toByteString' ac)) alice $ \wsA1 -> do Util.postOtrBroadcastMessage id alice ac msg !!! do const 201 === statusCode - assertTrue_ (eqMismatch [] [] [] . responseJsonUnsafe) + assertMismatch [] [] [] -- Bob should get the broadcast (team member of alice) void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc "ciphertext1") -- Charlie should get the broadcast (contact of alice and user of teams feature) @@ -1741,7 +1741,7 @@ postCryptoBroadcastMessageJsonFilteredTooLargeTeam = do let inbody = Just [alice, bob, charlie, dan] Util.postOtrBroadcastMessage' g inbody id alice ac msg !!! do const 201 === statusCode - assertTrue_ (eqMismatch [] [] [] . responseJsonUnsafe) + assertMismatch [] [] [] -- Bob should get the broadcast (team member of alice) void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc "ciphertext1") -- Charlie should get the broadcast (contact of alice and user of teams feature) @@ -1790,13 +1790,13 @@ postCryptoBroadcastMessageJson2 = do let m1 = [(bob, bc, "ciphertext1")] Util.postOtrBroadcastMessage id alice ac m1 !!! do const 412 === statusCode - assertTrue "1: Only Charlie and his device" (eqMismatch [(charlie, Set.singleton cc)] [] [] . responseJsonUnsafe) + assertMismatchWithMessage (Just "1: Only Charlie and his device") [(charlie, Set.singleton cc)] [] [] -- Complete WS.bracketR2 c bob charlie $ \(wsB, wsE) -> do let m2 = [(bob, bc, "ciphertext2"), (charlie, cc, "ciphertext2")] Util.postOtrBroadcastMessage id alice ac m2 !!! do const 201 === statusCode - assertTrue "No devices expected" (eqMismatch [] [] [] . responseJsonUnsafe) + assertMismatchWithMessage (Just "No devices expected") [] [] [] void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc "ciphertext2") void . liftIO $ WS.assertMatch t wsE (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc "ciphertext2") -- Redundant self @@ -1804,7 +1804,7 @@ postCryptoBroadcastMessageJson2 = do let m3 = [(alice, ac, "ciphertext3"), (bob, bc, "ciphertext3"), (charlie, cc, "ciphertext3")] Util.postOtrBroadcastMessage id alice ac m3 !!! do const 201 === statusCode - assertTrue "2: Only Alice and her device" (eqMismatch [] [(alice, Set.singleton ac)] [] . responseJsonUnsafe) + assertMismatchWithMessage (Just "2: Only Alice and her device") [] [(alice, Set.singleton ac)] [] void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc "ciphertext3") void . liftIO $ WS.assertMatch t wsE (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc "ciphertext3") -- Alice should not get it @@ -1815,7 +1815,7 @@ postCryptoBroadcastMessageJson2 = do let m4 = [(bob, bc, "ciphertext4"), (charlie, cc, "ciphertext4")] Util.postOtrBroadcastMessage id alice ac m4 !!! do const 201 === statusCode - assertTrue "3: Only Charlie and his device" (eqMismatch [] [] [(charlie, Set.singleton cc)] . responseJsonUnsafe) + assertMismatchWithMessage (Just "3: Only Charlie and his device") [] [] [(charlie, Set.singleton cc)] void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc "ciphertext4") -- charlie should not get it assertNoMsg wsE (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc "ciphertext4") @@ -1847,7 +1847,7 @@ postCryptoBroadcastMessageProto = do let msg = otrRecipients [(bob, [(bc, ciphertext)]), (charlie, [(cc, ciphertext)]), (dan, [(dc, ciphertext)])] Util.postProtoOtrBroadcast alice ac msg !!! do const 201 === statusCode - assertTrue_ (eqMismatch [] [] [] . responseJsonUnsafe) + assertMismatch [] [] [] -- Bob should get the broadcast (team member of alice) void . liftIO $ WS.assertMatch t wsB (wsAssertOtr' (encodeCiphertext "data") (q (selfConv bob)) (q alice) ac bc ciphertext) -- Charlie should get the broadcast (contact of alice and user of teams feature) @@ -1886,7 +1886,7 @@ postCryptoBroadcastMessage100OrMaxConns = do let msg = (bob, bc, "ciphertext") : (f <$> others) Util.postOtrBroadcastMessage id alice ac msg !!! do const 201 === statusCode - assertTrue_ (eqMismatch [] [] [] . responseJsonUnsafe) + assertMismatch [] [] [] let qbobself = Qualified (selfConv bob) localDomain void . liftIO $ WS.assertMatch t (Imports.head ws) (wsAssertOtr qbobself qalice ac bc "ciphertext") for_ (zip (tail ws) others) $ \(wsU, (u, clt)) -> do diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index bc88cc85ea3..5287d88392e 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -1162,8 +1162,8 @@ testClaimKeys testcase = do upgradeClientToLH peer peerClient putLHWhitelistTeam teamPeer !!! const 200 === statusCode - let assertResponse :: Assertions () - assertResponse = case testcase of + let assertResponse' :: Assertions () + assertResponse' = case testcase of TCKConsentMissing -> bad TCKOldClient -> bad TCKConsentAndNewClients -> good @@ -1173,10 +1173,10 @@ testClaimKeys testcase = do let fetchKeys :: ClientId -> TestM () fetchKeys legalholderLHDevice = do - getUsersPrekeysClientUnqualified peer legalholder legalholderLHDevice !!! assertResponse - getUsersPrekeyBundleUnqualified peer legalholder !!! assertResponse + getUsersPrekeysClientUnqualified peer legalholder legalholderLHDevice !!! assertResponse' + getUsersPrekeyBundleUnqualified peer legalholder !!! assertResponse' let userClients = UserClients (Map.fromList [(legalholder, Set.fromList [legalholderLHDevice])]) - getMultiUserPrekeyBundleUnqualified peer userClients !!! assertResponse + getMultiUserPrekeyBundleUnqualified peer userClients !!! assertResponse' putLHWhitelistTeam tid !!! const 200 === statusCode diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index d36c1719b13..e9b75dfa805 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -796,8 +796,8 @@ testClaimKeys testcase = do upgradeClientToLH peer peerClient grantConsent teamPeer peer - let assertResponse :: Assertions () - assertResponse = case testcase of + let assertResponse' :: Assertions () + assertResponse' = case testcase of TCKConsentMissing -> bad TCKOldClient -> bad TCKConsentAndNewClients -> good @@ -807,10 +807,10 @@ testClaimKeys testcase = do let fetchKeys :: ClientId -> TestM () fetchKeys legalholderLHDevice = do - getUsersPrekeysClientUnqualified peer legalholder legalholderLHDevice !!! assertResponse - getUsersPrekeyBundleUnqualified peer legalholder !!! assertResponse + getUsersPrekeysClientUnqualified peer legalholder legalholderLHDevice !!! assertResponse' + getUsersPrekeyBundleUnqualified peer legalholder !!! assertResponse' let userClients = UserClients (Map.fromList [(legalholder, Set.fromList [legalholderLHDevice])]) - getMultiUserPrekeyBundleUnqualified peer userClients !!! assertResponse + getMultiUserPrekeyBundleUnqualified peer userClients !!! assertResponse' withDummyTestServiceForTeam legalholder tid $ \_chan -> do grantConsent tid legalholder diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 01f5e7d54e0..37e60f81f9a 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -642,16 +642,32 @@ postOtrMessage' reportMissing f u d c rec = do . zType "access" . json (mkOtrPayload d rec reportMissing) +postProteusMessageQualifiedWithMockFederator :: + (ToJSON a) => + UserId -> + ClientId -> + Qualified ConvId -> + [(Qualified UserId, ClientId, ByteString)] -> + ByteString -> + Message.ClientMismatchStrategy -> + (FederatedRequest -> a) -> + TestM (ResponseLBS, Mock.ReceivedRequests) +postProteusMessageQualifiedWithMockFederator senderUser senderClient convId recipients dat strat responses = do + opts <- view tsGConf + withTempMockFederator opts (Domain "far-away.example.com") responses $ + postProteusMessageQualified senderUser senderClient convId recipients dat strat + postProteusMessageQualified :: + (MonadIO m, HasGalley m, MonadHttp m) => UserId -> ClientId -> Qualified ConvId -> [(Qualified UserId, ClientId, ByteString)] -> ByteString -> Message.ClientMismatchStrategy -> - TestM ResponseLBS + m ResponseLBS postProteusMessageQualified senderUser senderClient (Qualified conv domain) recipients dat strat = do - g <- view tsGalley + g <- viewGalley let protoMsg = mkQualifiedOtrPayload senderClient recipients dat strat post $ g @@ -1650,34 +1666,54 @@ convRange range size = privateAccess :: [Access] privateAccess = [PrivateAccess] -eqMismatch :: +assertExpected :: (Eq a, Show a) => String -> a -> (Response (Maybe LByteString) -> Maybe a) -> Assertions () +assertExpected msg expected tparser = + assertResponse $ \res -> + case tparser res of + Nothing -> Just (addTitle "Parsing the response failed") + Just parsed -> + if parsed == expected + then Nothing + else Just (addTitle (unlines ["Expected: ", show expected, "But got:", show parsed])) + where + addTitle s = unlines [msg, s] + +assertMismatchWithMessage :: + HasCallStack => + Maybe String -> [(UserId, Set ClientId)] -> [(UserId, Set ClientId)] -> [(UserId, Set ClientId)] -> - Maybe ClientMismatch -> - Bool -eqMismatch _ _ _ Nothing = False -eqMismatch mssd rdnt dltd (Just other) = - userClients mssd == missingClients other - && userClients rdnt == redundantClients other - && userClients dltd == deletedClients other + Assertions () +assertMismatchWithMessage mmsg missing redundant deleted = do + assertExpected (formatMessage "missing") (userClients missing) (fmap missingClients . responseJsonMaybe) + assertExpected (formatMessage "redundant") (userClients redundant) (fmap redundantClients . responseJsonMaybe) + assertExpected (formatMessage "deleted") (userClients deleted) (fmap deletedClients . responseJsonMaybe) where userClients :: [(UserId, Set ClientId)] -> UserClients userClients = UserClients . Map.fromList -eqMismatchQualified :: + formatMessage :: String -> String + formatMessage = maybe id (\msg -> ((msg <> "\n") <>)) mmsg + +assertMismatch :: + HasCallStack => + [(UserId, Set ClientId)] -> + [(UserId, Set ClientId)] -> + [(UserId, Set ClientId)] -> + Assertions () +assertMismatch = assertMismatchWithMessage Nothing + +assertMismatchQualified :: HasCallStack => Client.QualifiedUserClients -> Client.QualifiedUserClients -> Client.QualifiedUserClients -> - Maybe Message.MessageSendingStatus -> - Bool -eqMismatchQualified _ _ _ Nothing = False -eqMismatchQualified missing _redundant deleted (Just other) = do - missing == Message.mssMissingClients other - -- FUTUREWORK: reenable check once remote client discovery is implemented - -- && redundant == Message.mssRedundantClients other - && deleted == Message.mssDeletedClients other + Assertions () +assertMismatchQualified missing redundant deleted = do + assertExpected "missing" missing (fmap Message.mssMissingClients . responseJsonMaybe) + assertExpected "redundant" redundant (fmap Message.mssRedundantClients . responseJsonMaybe) + assertExpected "deleted" deleted (fmap Message.mssDeletedClients . responseJsonMaybe) otrRecipients :: [(UserId, [(ClientId, Text)])] -> OtrRecipients otrRecipients = OtrRecipients . UserClientMap . buildMap