Remote client discovery (#1635)

* Add function to fetch clients of remote members

* Fetch remote clients when sending messages

* Mock federator in one of the proteus tests

* missing clients test - use mock federator

* Bilge: add assertResponse (TODO: own PR)

* redudant and deleted clients: use mock federator

* Fix expectation in redundant and deleted test

* Add mock federator for ignore missing test

* Better failure messages for mismatch assertions

* Do not use hardcoded string for local domain

* Update CHANGELOG

Co-authored-by: Akshay Mankar <akshay@wire.com>

* Simplify assertion

* Parallelise getUserClients RPCs

Co-authored-by: Stefan Matting <stefan@wire.com>
Co-authored-by: Akshay Mankar <akshay@wire.com>

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
 

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 ()

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

services/galley/src/Galley/Data.hs

@@ -83,6 +83,7 @@ module Galley.Data
     addLocalMembersToRemoteConv,
     member,
     members,
+    lookupRemoteMembers,
     removeMember,
     removeMembers,
     removeLocalMembers,