diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 9bc504c8c6..f78d5823df 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -19,15 +19,18 @@ module Wire.API.Federation.API.Galley where import Control.Monad.Except (MonadError (..)) import Data.Aeson (FromJSON, ToJSON) +import Data.Domain (Domain) import Data.Id (ConvId, UserId) +import Data.Misc (Milliseconds) import Data.Qualified (Qualified) import Data.Time.Clock (UTCTime) import Imports -import Servant.API (JSON, Post, ReqBody, (:>)) +import Servant.API (JSON, Post, ReqBody, Summary, (:>)) import Servant.API.Generic ((:-)) import Servant.Client.Generic (AsClientT, genericClient) import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) -import Wire.API.Conversation (Conversation) +import Wire.API.Conversation (Access, AccessRole, ConvType, Conversation, ReceiptMode) +import Wire.API.Conversation.Member (Member (..)) import Wire.API.Conversation.Role (RoleName) import Wire.API.Federation.Client (FederationClientFailure, FederatorClient) import qualified Wire.API.Federation.GRPC.Types as Proto @@ -38,7 +41,15 @@ import Wire.API.Federation.Util.Aeson (CustomEncoded (CustomEncoded)) -- for the current list we need. data Api routes = Api - { getConversations :: + { -- | Register a new conversation + registerConversation :: + routes + :- "federation" + :> Summary "Register users to be in a new remote conversation" + :> "register-conversation" + :> ReqBody '[JSON] RegisterConversation + :> Post '[JSON] (), + getConversations :: routes :- "federation" :> "get-conversations" @@ -70,6 +81,31 @@ newtype GetConversationsResponse = GetConversationsResponse deriving (Arbitrary) via (GenericUniform GetConversationsResponse) deriving (ToJSON, FromJSON) via (CustomEncoded GetConversationsResponse) +-- | A record type describing a new federated conversation +-- +-- FUTUREWORK: Think about extracting common conversation metadata into a +-- separarate data type that can be reused in several data types in this module. +data RegisterConversation = MkRegisterConversation + { -- | The time when the conversation was created + rcTime :: UTCTime, + -- | The user that created the conversation + rcOrigUserId :: Qualified UserId, + -- | The qualified conversation ID + rcCnvId :: Qualified ConvId, + -- | The conversation type + rcCnvType :: ConvType, + rcCnvAccess :: [Access], + rcCnvAccessRole :: AccessRole, + -- | The conversation name, + rcCnvName :: Maybe Text, + -- | Members of the conversation grouped by their domain + rcMembers :: Map Domain [Member], + rcMessageTimer :: Maybe Milliseconds, + rcReceiptMode :: Maybe ReceiptMode + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON) via (CustomEncoded RegisterConversation) + data ConversationMemberUpdate = ConversationMemberUpdate { cmuTime :: UTCTime, cmuOrigUserId :: Qualified UserId, diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index d264e55cac..a498ae484d 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -100,11 +100,14 @@ import Wire.API.Conversation.Role (RoleName, roleNameWireAdmin) data Conversation = Conversation { cnvId :: ConvId, cnvType :: ConvType, + -- FUTUREWORK: Make this a qualified user ID. cnvCreator :: UserId, cnvAccess :: [Access], cnvAccessRole :: AccessRole, cnvName :: Maybe Text, cnvMembers :: ConvMembers, + -- FUTUREWORK: Think if it makes sense to make the team ID qualified due to + -- federation. cnvTeam :: Maybe TeamId, cnvMessageTimer :: Maybe Milliseconds, cnvReceiptMode :: Maybe ReceiptMode diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index 4bd6fd1114..45eacb74ac 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -30,7 +30,7 @@ import qualified Data.Aeson as Aeson import Data.ByteString.Conversion (toByteString') import Data.Domain (Domain) import Data.Handle -import Data.Id (ClientId) +import Data.Id (ClientId, ConvId) import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.Map as Map import Data.Qualified @@ -71,7 +71,8 @@ spec _brigOpts mg brig galley _federator brigTwo galleyTwo = test mg "claim prekey bundle" $ testClaimPrekeyBundleSuccess brig brigTwo, test mg "claim multi-prekey bundle" $ testClaimMultiPrekeyBundleSuccess brig brigTwo, test mg "list user clients" $ testListUserClients brig brigTwo, - test mg "add remote users to local conversation" $ testAddRemoteUsersToLocalConv brig galley brigTwo galleyTwo + test mg "add remote users to local conversation" $ testAddRemoteUsersToLocalConv brig galley brigTwo galleyTwo, + test mg "include remote users to new conversation" $ testRemoteUsersInNewConv brig galley brigTwo galleyTwo ] -- | Path covered by this test: @@ -257,6 +258,49 @@ testAddRemoteUsersToLocalConv brig1 galley1 brig2 galley2 = do expected' = [OtherMember (userQualifiedId alice) Nothing roleNameWireAdmin] liftIO $ actual' @?= expected' +-- | This creates a new conversation with a remote user. The test checks that +-- Galleys on both ends of the federation see the same conversation members. +testRemoteUsersInNewConv :: Brig -> Galley -> Brig -> Galley -> Http () +testRemoteUsersInNewConv brig1 galley1 brig2 galley2 = do + alice <- randomUser brig1 + bob <- randomUser brig2 + + let conv = NewConvUnmanaged $ NewConv [] [userQualifiedId bob] (Just "gossip") mempty Nothing Nothing Nothing Nothing roleNameWireAdmin + convId <- + cnvId . responseJsonUnsafe + <$> post + ( galley1 + . path "/conversations" + . zUser (userId alice) + . zConn "conn" + . header "Z-Type" "access" + . json conv + ) + let qconvId = Qualified convId (qDomain (userQualifiedId alice)) + -- test GET /conversations/:backend1Domain/:cnv + testQualifiedGetConversation galley1 "galley1" alice bob qconvId + testQualifiedGetConversation galley2 "galley2" bob alice qconvId + +-- | Test a scenario of a two-user conversation. +testQualifiedGetConversation :: + -- | A Galley to get information from + Galley -> + -- | A message to display during response parsing + String -> + -- | The user making the request + User -> + -- | The other user in the conversation + User -> + -- | A qualified conversation ID + Qualified ConvId -> + Http () +testQualifiedGetConversation galley msg alice bob qconvId = do + res <- getConvQualified galley (userId alice) qconvId " - get /conversations/domain/cnvId") res + actual = cmOthers $ cnvMembers conv + expected = [OtherMember (userQualifiedId bob) Nothing roleNameWireAdmin] + liftIO $ actual @?= expected + testListUserClients :: Brig -> Brig -> Http () testListUserClients brig1 brig2 = do alice <- randomUser brig1 diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index ea20270da0..e075123e50 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -106,7 +106,7 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do let (remotes, locals) = fromConvSize checkedPartitionedUsers ensureConnected zusr locals checkRemoteUsersExist remotes - -- FUTUREWORK: Implement (2) and (3) as per comments for Update.addMembers. (also for createTeamGroupConv) + -- FUTUREWORK: Implement (3) per comments for Update.addMembers. (also for createTeamGroupConv) c <- Data.createConversation localDomain @@ -167,7 +167,7 @@ createTeamGroupConv zusr zcon tinfo body = do ensureConnectedToLocals zusr (notTeamMember localUserIds (catMaybes convLocalMemberships)) pure checkedPartitionedUsers checkRemoteUsersExist remotes - -- FUTUREWORK: Implement (2) and (3) as per comments for Update.addMembers. + -- FUTUREWORK: Implement (3) per comments for Update.addMembers. conv <- Data.createConversation localDomain @@ -326,6 +326,14 @@ notifyCreatedConversation :: Maybe UTCTime -> UserId -> Maybe ConnId -> Data.Con notifyCreatedConversation dtime usr conn c = do localDomain <- viewFederationDomain now <- maybe (liftIO getCurrentTime) pure dtime + -- FUTUREWORK: Should these calls that push notifications to local and remote + -- users be made in this, or a different order, or in parallel/applicative + -- fashion? + -- + -- Ask remote server to store conversation membership and notify remote users + -- of being added to a conversation + registerRemoteConversationMemberships now localDomain c + -- Notify local users pushSome =<< mapM (toPush localDomain now) (Data.convLocalMembers c) where route diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 9b8487f5e4..4bea962ab8 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -17,27 +17,55 @@ module Galley.API.Federation where import Data.Containers.ListUtils (nubOrd) +import Data.Domain (Domain) +import Data.Id (UserId) +import qualified Data.Map as Map import Data.Qualified (Qualified (..)) import qualified Galley.API.Mapping as Mapping -import Galley.API.Util (pushConversationEvent, viewFederationDomain) +import Galley.API.Util (fromRegisterConversation, pushConversationEvent, viewFederationDomain) import Galley.App (Galley) import qualified Galley.Data as Data import Imports import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) +import Wire.API.Conversation.Member (Member, memId) import Wire.API.Event.Conversation -import Wire.API.Federation.API.Galley (ConversationMemberUpdate (..), GetConversationsRequest (..), GetConversationsResponse (..)) +import Wire.API.Federation.API.Galley (ConversationMemberUpdate (..), GetConversationsRequest (..), GetConversationsResponse (..), RegisterConversation (..)) import qualified Wire.API.Federation.API.Galley as FederationAPIGalley federationSitemap :: ServerT (ToServantApi FederationAPIGalley.Api) Galley federationSitemap = genericServerT $ FederationAPIGalley.Api - { FederationAPIGalley.getConversations = getConversations, + { FederationAPIGalley.registerConversation = registerConversation, + FederationAPIGalley.getConversations = getConversations, FederationAPIGalley.updateConversationMemberships = updateConversationMemberships } +registerConversation :: RegisterConversation -> Galley () +registerConversation rc = do + localDomain <- viewFederationDomain + let localUsers = fmap (toQualified localDomain) . getLocals $ localDomain + localUserIds = map qUnqualified localUsers + unless (null localUsers) $ do + Data.addLocalMembersToRemoteConv localUserIds (rcCnvId rc) + forM_ localUsers $ \usr -> do + c <- fromRegisterConversation usr rc + let event = + Event + ConvCreate + (rcCnvId rc) + (rcOrigUserId rc) + (rcTime rc) + (EdConversation c) + pushConversationEvent event [qUnqualified usr] [] + where + getLocals :: Domain -> [Member] + getLocals localDomain = fromMaybe [] . Map.lookup localDomain . rcMembers $ rc + toQualified :: Domain -> Member -> Qualified UserId + toQualified domain mem = Qualified (memId mem) domain + getConversations :: GetConversationsRequest -> Galley GetConversationsResponse getConversations (GetConversationsRequest qUid gcrConvIds) = do domain <- viewFederationDomain diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 1feb466dbb..f5a597eafb 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -14,12 +14,13 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE RecordWildCards #-} module Galley.API.Util where import Brig.Types (Relation (..)) import Brig.Types.Intra (ReAuthUser (..)) -import Control.Arrow ((&&&)) +import Control.Arrow (Arrow (second), (&&&)) import Control.Error (ExceptT) import Control.Lens (set, view, (.~), (^.)) import Control.Monad.Catch @@ -46,6 +47,7 @@ import Galley.Intra.User import Galley.Options (optSettings, setFederationDomain) import Galley.Types import Galley.Types.Conversations.Members (RemoteMember (..)) +import qualified Galley.Types.Conversations.Members as Members import Galley.Types.Conversations.Roles import Galley.Types.Teams hiding (Event) import Imports @@ -54,6 +56,8 @@ import Network.Wai import Network.Wai.Predicate hiding (Error) import Network.Wai.Utilities import UnliftIO (concurrently) +import qualified Wire.API.Conversation as Public +import qualified Wire.API.Conversation.Member as Member import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Federation.API.Galley as FederatedGalley import Wire.API.Federation.Client (FederationClientFailure, FederatorClient, executeFederated) @@ -305,7 +309,7 @@ canDeleteMember deleter deletee pushConversationEvent :: Event -> [UserId] -> [BotMember] -> Galley () pushConversationEvent e = pushJoinEvents (qUnqualified (evtFrom e)) Nothing e --- | Notify local users and bots of being added to a conversation +-- | Notify local users and bots of a conversation event pushJoinEvents :: UserId -> Maybe ConnId -> Event -> [UserId] -> [BotMember] -> Galley () pushJoinEvents usr conn e users bots = do for_ (newPush ListComplete usr (ConvEvent e) (userRecipient <$> users)) $ \p -> @@ -370,7 +374,140 @@ runFederated remoteDomain rpc = do runExceptT (executeFederated remoteDomain rpc) >>= either (throwM . federationErrorToWai) pure --- | Notify remote users of being added to a conversation +-- | Convert an internal conversation representation 'Data.Conversation' to +-- 'RegisterConversation' to be sent over the wire to a remote backend that will +-- reconstruct this into multiple public-facing +-- 'Wire.API.Conversation.Convevrsation' values, one per user from that remote +-- backend. +-- +-- FUTUREWORK: Include the team ID as well once it becomes qualified. +toRegisterConversation :: + -- | The time stamp the conversation was created at + UTCTime -> + -- | The domain of the user that created the conversation + Domain -> + -- | The conversation to convert for sending to a remote Galley + Data.Conversation -> + -- | The resulting information to be sent to a remote Galley + RegisterConversation +toRegisterConversation now localDomain Data.Conversation {..} = + MkRegisterConversation + { rcTime = now, + rcOrigUserId = Qualified convCreator localDomain, + rcCnvId = Qualified convId localDomain, + rcCnvType = convType, + rcCnvAccess = convAccess, + rcCnvAccessRole = convAccessRole, + rcCnvName = convName, + rcMembers = toMembers convLocalMembers convRemoteMembers, + rcMessageTimer = convMessageTimer, + rcReceiptMode = convReceiptMode + } + where + toMembers :: + [LocalMember] -> + [RemoteMember] -> + Map Domain [Member.Member] + toMembers ls rs = + let locals = Map.singleton localDomain . fmap localToMember $ ls + remotesUngrouped = fmap (second pure . remoteToMember) rs + in foldl' (flip (uncurry (Map.insertWith (<>)))) locals remotesUngrouped + localToMember :: LocalMember -> Member.Member + localToMember Members.InternalMember {..} = + Member.Member + { memId = memId, + .. + } + remoteToMember :: RemoteMember -> (Domain, Member.Member) + remoteToMember RemoteMember {..} = + ( qDomain . unTagged $ rmId, + Member.Member + { memId = qUnqualified . unTagged $ rmId, + memService = Nothing, + memOtrMuted = False, + memOtrMutedStatus = Nothing, + memOtrMutedRef = Nothing, + memOtrArchived = False, + memOtrArchivedRef = Nothing, + memHidden = False, + memHiddenRef = Nothing, + memConvRoleName = rmConvRoleName + } + ) + +-- | The function converts a 'RegisterConversation' value to a +-- 'Wire.API.Conversation.Conversation' value. The obtained value can be used in +-- e.g. creating an 'Event' to be sent out to users informing them that a new +-- conversation has been created. +fromRegisterConversation :: + Qualified UserId -> + RegisterConversation -> + Galley Public.Conversation +fromRegisterConversation (Qualified usr localDomain) MkRegisterConversation {..} = do + this <- me rcMembers + pure + Public.Conversation + { cnvId = qUnqualified rcCnvId, + cnvType = rcCnvType, + -- FUTUREWORK: a UserId from another instance is communicated here, which + -- without domain does not make much sense here. + cnvCreator = qUnqualified rcOrigUserId, + cnvAccess = rcCnvAccess, + cnvAccessRole = rcCnvAccessRole, + cnvName = rcCnvName, + cnvMembers = ConvMembers this (others rcMembers), + -- FUTUREWORK: Once conversation IDs become qualified, this information + -- should be sent from the hosting Galley and stored here in 'cnvTeam'. + cnvTeam = Nothing, + cnvMessageTimer = rcMessageTimer, + cnvReceiptMode = rcReceiptMode + } + where + me :: Map Domain [Public.Member] -> Galley Public.Member + me m = case Map.lookup localDomain m >>= find ((usr ==) . Member.memId) of + Nothing -> throwM convMemberNotFound + Just v -> pure v + others :: Map Domain [Public.Member] -> [OtherMember] + others = + Map.foldlWithKey' (\acc d mems -> fmap (memToOther d) mems <> acc) [] + -- make sure not to include 'usr' in the list of others + . Map.adjust (filter ((usr /=) . Public.memId)) localDomain + memToOther :: Domain -> Member.Member -> OtherMember + memToOther d mem = + OtherMember + { omQualifiedId = Qualified (Member.memId mem) d, + omService = Member.memService mem, + omConvRoleName = Member.memConvRoleName mem + } + +-- | Notify remote users of being added to a new conversation +registerRemoteConversationMemberships :: + -- | The time stamp when the conversation was created + UTCTime -> + -- | The domain of the user that created the conversation + Domain -> + Data.Conversation -> + Galley () +registerRemoteConversationMemberships now localDomain c = do + let rc = toRegisterConversation now localDomain c + -- FUTUREWORK: parallelise federated requests + traverse_ (registerRemoteConversations rc) + . Map.keys + . partitionQualified + . nubOrd + . map (unTagged . rmId) + . Data.convRemoteMembers + $ c + where + registerRemoteConversations :: + RegisterConversation -> + Domain -> + Galley () + registerRemoteConversations rc domain = do + let rpc = FederatedGalley.registerConversation FederatedGalley.clientRoutes rc + runFederated domain rpc + +-- | Notify remote users of being added to an existing conversation updateRemoteConversationMemberships :: [RemoteMember] -> UserId -> UTCTime -> Data.Conversation -> [LocalMember] -> [RemoteMember] -> Galley () updateRemoteConversationMemberships existingRemotes usr now c lmm rmm = do localDomain <- viewFederationDomain @@ -384,15 +521,6 @@ updateRemoteConversationMemberships existingRemotes usr now c lmm rmm = do . nubOrd . map (unTagged . rmId) $ rmm <> existingRemotes - where - catMembers :: - Domain -> - [LocalMember] -> - [RemoteMember] -> - [(Qualified UserId, RoleName)] - catMembers localDomain ls rs = - map (((`Qualified` localDomain) . memId) &&& memConvRoleName) ls - <> map ((unTagged . rmId) &&& rmConvRoleName) rs updateRemoteConversations :: UTCTime -> @@ -414,3 +542,12 @@ updateRemoteConversations now uids orig cnv domain others = do } let rpc = FederatedGalley.updateConversationMemberships FederatedGalley.clientRoutes cmu runFederated domain rpc + +catMembers :: + Domain -> + [LocalMember] -> + [RemoteMember] -> + [(Qualified UserId, RoleName)] +catMembers localDomain ls rs = + map (((`Qualified` localDomain) . memId) &&& memConvRoleName) ls + <> map ((unTagged . rmId) &&& rmConvRoleName) rs diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 9aea0e63b6..d1a32b8090 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -856,9 +856,9 @@ addMembersUncheckedWithRole localDomain t conv (orig, _origRole) lusrs rusrs = d e = Event MemberJoin qconv qorig t (EdMembersJoin (SimpleMembers (lmems <> rmems))) return (e, fmap (uncurry newMemberWithRole) lusrs, fmap (uncurry RemoteMember) rusrs) --- | Set local users as belonging to a remote conversation. This is invoked by --- a remote galley (using the RPC updateConversationMembership) when users from --- the current backend are added to conversations on the remote end. +-- | Set local users as belonging to a remote conversation. This is invoked by a +-- remote galley when users from the current backend are added to conversations +-- on the remote end. addLocalMembersToRemoteConv :: MonadClient m => [UserId] -> Qualified ConvId -> m () addLocalMembersToRemoteConv users qconv = do -- FUTUREWORK: consider using pooledMapConcurrentlyN