From aaa6452aafd80903cc38d2ecd31ad932e3e41ef7 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 19 Dec 2022 10:18:34 +0100 Subject: [PATCH] Commit bundles for subconversations (#2932) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Add subconversation group info endpoint (wip, untested) * Fill implemention holes * refactor clientmap and add TODO for check * Throw when a client is not in the parent conv * Remove duplication in MLSConversation type * Refactor: Introduce incrementEpoch * Refactor: unqualify parent in SubConversation type * Bump mls-test-cli * Store group info bundle for subconvs * Fix epoch increment query for subconvs * Add join subconversation test * Turn TODO into FUTUREWORK * Add stubs of more subconversation tests * Add CHANGELOG entries * Deduplicate function to fetch remote group info Co-authored-by: Stefan Matting Co-authored-by: Marko Dimjašević --- .../get-subconversation-groupinfo | 1 + changelog.d/2-features/subconv-commit-bundles | 1 + .../src/Wire/API/Federation/API/Galley.hs | 6 +- .../src/Wire/API/MLS/SubConversation.hs | 3 +- .../API/Routes/Public/Galley/Conversation.hs | 21 ++++ nix/pkgs/mls-test-cli/default.nix | 4 +- services/galley/galley.cabal | 1 + services/galley/src/Galley/API/Action.hs | 4 +- services/galley/src/Galley/API/Federation.hs | 14 ++- .../galley/src/Galley/API/MLS/Conversation.hs | 57 +++++++++ .../galley/src/Galley/API/MLS/GroupInfo.hs | 5 +- services/galley/src/Galley/API/MLS/Message.hs | 115 ++++++++++-------- .../galley/src/Galley/API/MLS/Propagate.hs | 71 +++++------ services/galley/src/Galley/API/MLS/Removal.hs | 21 ++-- .../src/Galley/API/MLS/SubConversation.hs | 58 ++++++++- services/galley/src/Galley/API/MLS/Types.hs | 39 ++++-- .../src/Galley/API/Public/Conversation.hs | 1 + .../galley/src/Galley/Cassandra/Queries.hs | 3 + .../src/Galley/Cassandra/SubConversation.hs | 9 +- .../galley/src/Galley/Effects/MemberStore.hs | 5 +- .../Galley/Effects/SubConversationStore.hs | 3 +- services/galley/test/integration/API/MLS.hs | 84 ++++++++++--- .../galley/test/integration/API/MLS/Util.hs | 57 ++++++--- 23 files changed, 408 insertions(+), 175 deletions(-) create mode 100644 changelog.d/1-api-changes/get-subconversation-groupinfo create mode 100644 changelog.d/2-features/subconv-commit-bundles create mode 100644 services/galley/src/Galley/API/MLS/Conversation.hs diff --git a/changelog.d/1-api-changes/get-subconversation-groupinfo b/changelog.d/1-api-changes/get-subconversation-groupinfo new file mode 100644 index 00000000000..32845ff8279 --- /dev/null +++ b/changelog.d/1-api-changes/get-subconversation-groupinfo @@ -0,0 +1 @@ +Add `GET /conversations/:domain/:cid/subconversations/:id/groupinfo` endpoint to fetch the group info object for a subconversation diff --git a/changelog.d/2-features/subconv-commit-bundles b/changelog.d/2-features/subconv-commit-bundles new file mode 100644 index 00000000000..a6db49b6183 --- /dev/null +++ b/changelog.d/2-features/subconv-commit-bundles @@ -0,0 +1 @@ +Add support for subconversations in `POST /mls/commit-bundles` 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 90fc7de3e37..2166f915c5a 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 @@ -351,9 +351,9 @@ data MLSMessageResponse deriving (ToJSON, FromJSON) via (CustomEncoded MLSMessageResponse) data GetGroupInfoRequest = GetGroupInfoRequest - { -- | Conversation is assumed to be owned by the target domain, this allows - -- us to protect against relay attacks - ggireqConv :: ConvId, + { -- | Conversation (or subconversation) is assumed to be owned by the target + -- domain, this allows us to protect against relay attacks + ggireqConv :: ConvOrSubConvId, -- | Sender is assumed to be owned by the origin domain, this allows us to -- protect against spoofing attacks ggireqSender :: UserId diff --git a/libs/wire-api/src/Wire/API/MLS/SubConversation.hs b/libs/wire-api/src/Wire/API/MLS/SubConversation.hs index a0d3ccf386c..10e79f727b7 100644 --- a/libs/wire-api/src/Wire/API/MLS/SubConversation.hs +++ b/libs/wire-api/src/Wire/API/MLS/SubConversation.hs @@ -46,10 +46,9 @@ import Wire.Arbitrary -- conversation. The pair of a qualified conversation ID and a subconversation -- ID identifies globally. newtype SubConvId = SubConvId {unSubConvId :: Text} - deriving newtype (Eq, ToSchema, Ord) + deriving newtype (Eq, ToSchema, Ord, S.ToParamSchema, ToByteString) deriving stock (Generic) deriving (Arbitrary) via (GenericUniform SubConvId) - deriving newtype (S.ToParamSchema) deriving stock (Show) instance FromHttpApiData SubConvId where diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs index 1fcc514df16..ddf0e9e7079 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs @@ -396,6 +396,27 @@ type ConversationAPI = PublicSubConversation ) ) + :<|> Named + "get-subconversation-group-info" + ( Summary "Get MLS group information of subconversation" + :> CanThrow 'ConvNotFound + :> CanThrow 'MLSMissingGroupInfo + :> CanThrow 'MLSNotEnabled + :> ZLocalUser + :> "conversations" + :> QualifiedCapture "cnv" ConvId + :> "subconversations" + :> Capture "subconv" SubConvId + :> "groupinfo" + :> MultiVerb1 + 'GET + '[MLS] + ( Respond + 200 + "The group information" + OpaquePublicGroupState + ) + ) -- This endpoint can lead to the following events being sent: -- - ConvCreate event to members -- TODO: add note: "On 201, the conversation ID is the `Location` header" diff --git a/nix/pkgs/mls-test-cli/default.nix b/nix/pkgs/mls-test-cli/default.nix index 7d7d6961133..b49f61ceaa1 100644 --- a/nix/pkgs/mls-test-cli/default.nix +++ b/nix/pkgs/mls-test-cli/default.nix @@ -15,8 +15,8 @@ rustPlatform.buildRustPackage rec { src = fetchFromGitHub { owner = "wireapp"; repo = "mls-test-cli"; - sha256 = "sha256-/XQ/9oQTPkRqgMzDGRm+Oh9jgkdeDM1vRJ6/wEf2+bY="; - rev = "c6f80be2839ac1ed2894e96044541d1c3cf6ecdf"; + sha256 = "sha256-FjgAcYdUr/ZWdQxbck2UEG6NEEQLuz0S4a55hrAxUs4="; + rev = "82fc148964ef5baa92a90d086fdc61adaa2b5dbf"; }; doCheck = false; cargoSha256 = "sha256-AlZrxa7f5JwxxrzFBgeFSaYU6QttsUpfLYfq1HzsdbE="; diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 346c984e7d8..fd5b9db4bad 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -31,6 +31,7 @@ library Galley.API.Mapping Galley.API.Message Galley.API.MLS + Galley.API.MLS.Conversation Galley.API.MLS.Enabled Galley.API.MLS.GroupInfo Galley.API.MLS.KeyPackage diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 1fd27effc6e..dfa6fc67362 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -635,8 +635,8 @@ updateLocalConversationUnchecked lconv qusr con action = do (convBotsAndMembers conv <> extraTargets) action' --- -------------------------------------------------------------------------------- --- -- Utilities +-------------------------------------------------------------------------------- +-- Utilities ensureConversationActionAllowed :: forall tag mem x r. diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index dbf85df9149..ef1f4851677 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -44,6 +44,7 @@ import Galley.API.MLS.GroupInfo import Galley.API.MLS.KeyPackage import Galley.API.MLS.Message import Galley.API.MLS.Removal +import Galley.API.MLS.SubConversation import Galley.API.MLS.Welcome import qualified Galley.API.Mapping as Mapping import Galley.API.Message @@ -91,6 +92,7 @@ import Wire.API.MLS.Credential import Wire.API.MLS.Message import Wire.API.MLS.PublicGroupState import Wire.API.MLS.Serialisation +import Wire.API.MLS.SubConversation import Wire.API.MLS.Welcome import Wire.API.Message import Wire.API.Routes.Internal.Brig.Connection @@ -795,7 +797,8 @@ queryGroupInfo :: ( Members '[ ConversationStore, Input (Local ()), - Input Env + Input Env, + SubConversationStore ] r, Member MemberStore r @@ -809,9 +812,14 @@ queryGroupInfo origDomain req = . mapToGalleyError @MLSGroupInfoStaticErrors $ do assertMLSEnabled - lconvId <- qualifyLocal . ggireqConv $ req let sender = toRemoteUnsafe origDomain . ggireqSender $ req - state <- getGroupInfoFromLocalConv (tUntagged sender) lconvId + state <- case ggireqConv req of + Conv convId -> do + lconvId <- qualifyLocal convId + getGroupInfoFromLocalConv (tUntagged sender) lconvId + SubConv convId subConvId -> do + lconvId <- qualifyLocal convId + getSubConversationGroupInfoFromLocalConv (tUntagged sender) subConvId lconvId pure . Base64ByteString . unOpaquePublicGroupState diff --git a/services/galley/src/Galley/API/MLS/Conversation.hs b/services/galley/src/Galley/API/MLS/Conversation.hs new file mode 100644 index 00000000000..fb2396d9c83 --- /dev/null +++ b/services/galley/src/Galley/API/MLS/Conversation.hs @@ -0,0 +1,57 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.API.MLS.Conversation + ( mkMLSConversation, + mcConv, + ) +where + +import Galley.API.MLS.Types +import Galley.Data.Conversation.Types as Data +import Galley.Effects.MemberStore +import Imports +import Polysemy +import Wire.API.Conversation.Protocol + +mkMLSConversation :: + Member MemberStore r => + Data.Conversation -> + Sem r (Maybe MLSConversation) +mkMLSConversation conv = + for (Data.mlsMetadata conv) $ \mlsData -> do + cm <- lookupMLSClients (cnvmlsGroupId mlsData) + pure + MLSConversation + { mcId = Data.convId conv, + mcMetadata = Data.convMetadata conv, + mcLocalMembers = Data.convLocalMembers conv, + mcRemoteMembers = Data.convRemoteMembers conv, + mcMLSData = mlsData, + mcMembers = cm + } + +mcConv :: MLSConversation -> Data.Conversation +mcConv mlsConv = + Data.Conversation + { convId = mcId mlsConv, + convLocalMembers = mcLocalMembers mlsConv, + convRemoteMembers = mcRemoteMembers mlsConv, + convDeleted = False, + convMetadata = mcMetadata mlsConv, + convProtocol = ProtocolMLS (mcMLSData mlsConv) + } diff --git a/services/galley/src/Galley/API/MLS/GroupInfo.hs b/services/galley/src/Galley/API/MLS/GroupInfo.hs index ea2b16c78d8..3512c5d85c7 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfo.hs +++ b/services/galley/src/Galley/API/MLS/GroupInfo.hs @@ -37,6 +37,7 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.SubConversation type MLSGroupInfoStaticErrors = '[ ErrorS 'ConvNotFound, @@ -62,7 +63,7 @@ getGroupInfo lusr qcnvId = do foldQualified lusr (getGroupInfoFromLocalConv . tUntagged $ lusr) - (getGroupInfoFromRemoteConv lusr) + (getGroupInfoFromRemoteConv lusr . fmap Conv) qcnvId getGroupInfoFromLocalConv :: @@ -84,7 +85,7 @@ getGroupInfoFromRemoteConv :: Members '[Error FederationError, FederatorAccess] r => Members MLSGroupInfoStaticErrors r => Local UserId -> - Remote ConvId -> + Remote ConvOrSubConvId -> Sem r OpaquePublicGroupState getGroupInfoFromRemoteConv lusr rcnv = do let getRequest = diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 4e908005475..5242d900f4b 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -39,6 +39,7 @@ import qualified Data.Text as T import Data.Time import Galley.API.Action import Galley.API.Error +import Galley.API.MLS.Conversation import Galley.API.MLS.Enabled import Galley.API.MLS.KeyPackage import Galley.API.MLS.Propagate @@ -599,10 +600,10 @@ instance Monoid ProposalAction where mempty = ProposalAction mempty mempty mempty paAddClient :: Qualified (UserId, (ClientId, KeyPackageRef)) -> ProposalAction -paAddClient quc = mempty {paAdd = Map.singleton (fmap fst quc) (Set.singleton (snd (qUnqualified quc)))} +paAddClient quc = mempty {paAdd = Map.singleton (fmap fst quc) (uncurry Map.singleton (snd (qUnqualified quc)))} paRemoveClient :: Qualified (UserId, (ClientId, KeyPackageRef)) -> ProposalAction -paRemoveClient quc = mempty {paRemove = Map.singleton (fmap fst quc) (Set.singleton (snd (qUnqualified quc)))} +paRemoveClient quc = mempty {paRemove = Map.singleton (fmap fst quc) (uncurry Map.singleton (snd (qUnqualified quc)))} paExternalInitPresent :: ProposalAction paExternalInitPresent = mempty {paExternalInit = Any True} @@ -733,6 +734,13 @@ processExternalCommit qusr mSenderClient lConvOrSub epoch action updatePath = wi throw . mlsProtocolError $ "The external commit attempts to add another client of the user, it must only add itself" + case convOrSub of + Conv _ -> pure () + SubConv mlsConv _ -> + unless (isJust (cmLookupRef cid (mcMembers mlsConv))) $ + throw . mlsProtocolError $ + "Cannot join a subconversation before joining the parent conversation" + -- check if there is a key package ref in the remove proposal remRef <- if Map.null (paRemove action) @@ -748,29 +756,26 @@ processExternalCommit qusr mSenderClient lConvOrSub epoch action updatePath = wi updateKeyPackageMapping lConvOrSub qusr (ciClient cid) remRef newRef -- increment epoch number - setConvOrSubEpoch (idForConvOrSub convOrSub) (succ epoch) - -- fetch conversation or sub with new epoch - lConvOrSub' <- fetchConvOrSub qusr (idForConvOrSub <$> lConvOrSub) - let convOrSub' = tUnqualified lConvOrSub + lConvOrSub' <- for lConvOrSub incrementEpoch -- fetch backend remove proposals of the previous epoch - kpRefs <- getPendingBackendRemoveProposals (cnvmlsGroupId . mlsMetaConvOrSub $ convOrSub') epoch + kpRefs <- getPendingBackendRemoveProposals (cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub') epoch -- requeue backend remove proposals for the current epoch removeClientsWithClientMap lConvOrSub' kpRefs qusr where derefUser :: ClientMap -> Qualified UserId -> Sem r (ClientIdentity, KeyPackageRef) - derefUser (Map.toList -> l) user = case l of - [(u, s)] -> do + derefUser cm user = case Map.assocs cm of + [(u, clients)] -> do unless (user == u) $ throwS @'MLSClientSenderUserMismatch - ref <- snd <$> ensureSingleton s + ref <- ensureSingleton clients ci <- derefKeyPackage ref unless (cidQualifiedUser ci == user) $ throwS @'MLSClientSenderUserMismatch pure (ci, ref) _ -> throwRemProposal - ensureSingleton :: Set a -> Sem r a - ensureSingleton (Set.toList -> l) = case l of + ensureSingleton :: Map k a -> Sem r a + ensureSingleton m = case Map.elems m of [e] -> pure e _ -> throwRemProposal throwRemProposal = @@ -826,6 +831,7 @@ processInternalCommit :: Member (ErrorS 'MissingLegalholdConsent) r, Member (Input (Local ())) r, Member ProposalStore r, + Member SubConversationStore r, Member BrigAccess r, Member Resource r ) => @@ -841,20 +847,15 @@ processInternalCommit :: processInternalCommit qusr senderClient con lConvOrSub epoch action senderRef commit = do let convOrSub = tUnqualified lConvOrSub mlsMeta = mlsMetaConvOrSub convOrSub - self <- - noteS @'ConvNotFound $ - getConvMember - lConvOrSub - (mcConv . convOfConvOrSub $ convOrSub) - qusr + localSelf = isLocal lConvOrSub qusr withCommitLock (cnvmlsGroupId . mlsMetaConvOrSub $ convOrSub) epoch $ do postponedKeyPackageRefUpdate <- if epoch == Epoch 0 then do - let cType = cnvmType . convMetadata . mcConv . convOfConvOrSub $ convOrSub - case (self, cType, cmAssocs . membersConvOrSub $ convOrSub, convOrSub) of - (Left _, SelfConv, [], Conv _) -> do + let cType = cnvmType . mcMetadata . convOfConvOrSub $ convOrSub + case (localSelf, cType, cmAssocs . membersConvOrSub $ convOrSub, convOrSub) of + (True, SelfConv, [], Conv _) -> do creatorClient <- noteS @'MLSMissingSenderClient senderClient creatorRef <- maybe @@ -868,12 +869,12 @@ processInternalCommit qusr senderClient con lConvOrSub epoch action senderRef co (cnvmlsGroupId mlsMeta) qusr (Set.singleton (creatorClient, creatorRef)) - (Left _, SelfConv, _, _) -> + (True, SelfConv, _, _) -> -- this is a newly created (sub)conversation, and it should -- contain exactly one client (the creator) throw (InternalErrorWithDescription "Unexpected creator client set") - (Left lm, _, [(qu, (creatorClient, _))], Conv _) - | qu == tUntagged (qualifyAs lConvOrSub (lmId lm)) -> do + (True, _, [(qu, (creatorClient, _))], Conv _) + | qu == qusr -> do -- use update path as sender reference and if not existing fall back to sender senderRef' <- maybe @@ -891,7 +892,7 @@ processInternalCommit qusr senderClient con lConvOrSub epoch action senderRef co Nothing senderRef' -- remote clients cannot send the first commit - (Right _, _, _, _) -> throwS @'MLSStaleMessage + (False, _, _, _) -> throwS @'MLSStaleMessage (_, _, _, SubConv _ _) -> pure () -- uninitialised conversations should contain exactly one client (_, _, _, Conv _) -> @@ -926,7 +927,7 @@ processInternalCommit qusr senderClient con lConvOrSub epoch action senderRef co -- update key package ref if necessary postponedKeyPackageRefUpdate -- increment epoch number - setConvOrSubEpoch (idForConvOrSub convOrSub) (succ epoch) + for_ lConvOrSub incrementEpoch pure updates @@ -1071,7 +1072,7 @@ processProposal qusr lConvOrSub msg prop = do checkEpoch (msgEpoch msg) mlsMeta checkGroup (msgGroupId msg) mlsMeta let suiteTag = cnvmlsCipherSuite mlsMeta - let cid = convId . mcConv . convOfConvOrSub . tUnqualified $ lConvOrSub + let cid = mcId . convOfConvOrSub . tUnqualified $ lConvOrSub -- validate the proposal -- @@ -1206,7 +1207,7 @@ executeProposalAction loc qusr con (Conv mlsConv) action = do -- out all removals of that type, so that further checks and processing can -- be applied only to type 1 removals. removedUsers <- mapMaybe hush <$$> for (Map.assocs (paRemove action)) $ - \(qtarget, Set.map fst -> clients) -> runError @() $ do + \(qtarget, Map.keysSet -> clients) -> runError @() $ do -- fetch clients from brig clientInfo <- Set.map ciId <$> getClientInfo lconv qtarget ss -- if the clients being removed don't exist, consider this as a removal of @@ -1225,7 +1226,7 @@ executeProposalAction loc qusr con (Conv mlsConv) action = do -- new user Nothing -> do -- final set of clients in the conversation - let clients = Set.map fst (newclients <> Map.findWithDefault mempty qtarget cm) + let clients = Map.keysSet (newclients <> Map.findWithDefault mempty qtarget cm) -- get list of mls clients from brig clientInfo <- getClientInfo lconv qtarget ss let allClients = Set.map ciId clientInfo @@ -1255,7 +1256,7 @@ executeProposalAction loc qusr con (Conv mlsConv) action = do -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do - addMLSClients (cnvmlsGroupId mlsMeta) qtarget newClients + addMLSClients (cnvmlsGroupId mlsMeta) qtarget (Set.fromList (Map.assocs newClients)) -- remove users from the conversation and send events removeEvents <- foldMap (removeMembers lconv) (nonEmpty membersToRemove) @@ -1263,7 +1264,7 @@ executeProposalAction loc qusr con (Conv mlsConv) action = do -- Remove clients from the conversation state. This includes client removals -- of all types (see Note [client removal]). for_ (Map.assocs (paRemove action)) $ \(qtarget, clients) -> do - removeMLSClients (cnvmlsGroupId mlsMeta) qtarget (Set.map fst clients) + removeMLSClients (cnvmlsGroupId mlsMeta) qtarget (Map.keysSet clients) pure (addEvents <> removeEvents) where @@ -1273,7 +1274,7 @@ executeProposalAction loc qusr con (Conv mlsConv) action = do Set ClientId -> Sem r (Maybe (Qualified UserId)) checkRemoval cm qtarget clients = do - let clientsInConv = Set.map fst (Map.findWithDefault mempty qtarget cm) + let clientsInConv = Map.keysSet (Map.findWithDefault mempty qtarget cm) when (clients /= clientsInConv) $ do -- FUTUREWORK: turn this error into a proper response throwS @'MLSClientMismatch @@ -1441,15 +1442,11 @@ storeGroupInfoBundle :: ConvOrSubConvId -> GroupInfoBundle -> Sem r () -storeGroupInfoBundle convOrSub bundle = case convOrSub of - Conv cid -> do - setPublicGroupState cid - . toOpaquePublicGroupState - . gipGroupState - $ bundle - SubConv _cid _subconvid -> do - -- FUTUREWORK: Write to subconversation - pure () +storeGroupInfoBundle convOrSub bundle = do + let gs = toOpaquePublicGroupState (gipGroupState bundle) + case convOrSub of + Conv cid -> setPublicGroupState cid gs + SubConv cid subconvid -> setSubConversationPublicGroupState cid subconvid (Just gs) fetchConvOrSub :: forall r. @@ -1469,19 +1466,29 @@ fetchConvOrSub qusr convOrSubId = for convOrSubId $ \case SubConv convId sconvId -> do let lconv = qualifyAs convOrSubId convId c <- getMLSConv qusr lconv - subconv <- getSubConversation lconv sconvId >>= noteS @'ConvNotFound + subconv <- getSubConversation convId sconvId >>= noteS @'ConvNotFound pure (SubConv c subconv) where getMLSConv :: Qualified UserId -> Local ConvId -> Sem r MLSConversation - getMLSConv u lconv = do - c <- getLocalConvForUser u lconv - meta <- mlsMetadata c & noteS @'ConvNotFound - cm <- lookupMLSClients (cnvmlsGroupId meta) - pure $ MLSConversation c meta cm - -setConvOrSubEpoch :: Members '[ConversationStore] r => ConvOrSubConvId -> Epoch -> Sem r () -setConvOrSubEpoch (Conv cid) epoch = - setConversationEpoch cid epoch -setConvOrSubEpoch (SubConv _ _) _epoch = - -- FUTUREWORK: Write to subconversation - pure () + getMLSConv u = + getLocalConvForUser u + >=> mkMLSConversation + >=> noteS @'ConvNotFound + +incrementEpoch :: + Members + '[ ConversationStore, + SubConversationStore + ] + r => + ConvOrSubConv -> + Sem r ConvOrSubConv +incrementEpoch (Conv c) = do + let epoch' = succ (cnvmlsEpoch (mcMLSData c)) + setConversationEpoch (mcId c) epoch' + pure $ Conv c {mcMLSData = (mcMLSData c) {cnvmlsEpoch = epoch'}} +incrementEpoch (SubConv c s) = do + let epoch' = succ (cnvmlsEpoch (scMLSData s)) + setSubConversationEpoch (scParentConvId s) (scSubConvId s) epoch' + let s' = s {scMLSData = (scMLSData s) {cnvmlsEpoch = epoch'}} + pure (SubConv c s') diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index c7cbb2a3efb..9809fda6fb5 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -26,7 +26,6 @@ import Data.Qualified import Data.Time import Galley.API.MLS.Types import Galley.API.Push -import qualified Galley.Data.Conversation.Types as Data import Galley.Data.Services import Galley.Effects import Galley.Effects.FederatorAccess @@ -44,7 +43,6 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import Wire.API.MLS.SubConversation import Wire.API.Message -- | Propagate a message. @@ -61,43 +59,36 @@ propagateMessage :: ByteString -> Sem r () propagateMessage qusr lConvOrSub con raw = do - case tUnqualified lConvOrSub of - (SubConv _ _) -> do - -- FUTUREWORK: Implement propagating the message to the subconversation - pure () - (Conv mlsMessage) -> do - let lMlsMessage = qualifyAs lConvOrSub mlsMessage - let cm = mcMembers mlsMessage - lconv = mcConv <$> lMlsMessage - -- FUTUREWORK: check the epoch - let lmems = Data.convLocalMembers . tUnqualified $ lconv - botMap = Map.fromList $ do - m <- lmems - b <- maybeToList $ newBotMember m - pure (lmId m, b) - mm = defMessageMetadata - now <- input @UTCTime - let lcnv = fmap Data.convId lconv - qcnv = tUntagged lcnv - e = Event qcnv qusr now $ EdMLSMessage raw - mkPush :: UserId -> ClientId -> MessagePush 'NormalMessage - mkPush u c = newMessagePush lcnv botMap con mm (u, c) e - runMessagePush lconv (Just qcnv) $ - foldMap (uncurry mkPush) (lmems >>= localMemberMLSClients lcnv cm) + now <- input @UTCTime + let cm = membersConvOrSub (tUnqualified lConvOrSub) + mlsConv = convOfConvOrSub <$> lConvOrSub + lmems = mcLocalMembers . tUnqualified $ mlsConv + botMap = Map.fromList $ do + m <- lmems + b <- maybeToList $ newBotMember m + pure (lmId m, b) + mm = defMessageMetadata + qcnv = tUntagged (fmap mcId mlsConv) + -- FUTUREWORK: Add subconv field + e = Event qcnv qusr now $ EdMLSMessage raw + mkPush :: UserId -> ClientId -> MessagePush 'NormalMessage + mkPush u c = newMessagePush mlsConv botMap con mm (u, c) e + runMessagePush mlsConv (Just qcnv) $ + foldMap (uncurry mkPush) (lmems >>= localMemberMLSClients mlsConv cm) - -- send to remotes - traverse_ handleError - <=< runFederatedConcurrentlyEither (map remoteMemberQualify (Data.convRemoteMembers . tUnqualified $ lconv)) - $ \(tUnqualified -> rs) -> - fedClient @'Galley @"on-mls-message-sent" $ - RemoteMLSMessage - { rmmTime = now, - rmmSender = qusr, - rmmMetadata = mm, - rmmConversation = tUnqualified lcnv, - rmmRecipients = rs >>= remoteMemberMLSClients cm, - rmmMessage = Base64ByteString raw - } + -- send to remotes + traverse_ handleError + <=< runFederatedConcurrentlyEither (map remoteMemberQualify (mcRemoteMembers . tUnqualified $ mlsConv)) + $ \(tUnqualified -> rs) -> + fedClient @'Galley @"on-mls-message-sent" $ + RemoteMLSMessage + { rmmTime = now, + rmmSender = qusr, + rmmMetadata = mm, + rmmConversation = qUnqualified qcnv, + rmmRecipients = rs >>= remoteMemberMLSClients cm, + rmmMessage = Base64ByteString raw + } where localMemberMLSClients :: Local x -> ClientMap -> LocalMember -> [(UserId, ClientId)] localMemberMLSClients loc cm lm = @@ -105,7 +96,7 @@ propagateMessage qusr lConvOrSub con raw = do localUserId = lmId lm in map (\(c, _) -> (localUserId, c)) - (toList (Map.findWithDefault mempty localUserQId cm)) + (Map.assocs (Map.findWithDefault mempty localUserQId cm)) remoteMemberMLSClients :: ClientMap -> RemoteMember -> [(UserId, ClientId)] remoteMemberMLSClients cm rm = @@ -113,7 +104,7 @@ propagateMessage qusr lConvOrSub con raw = do remoteUserId = qUnqualified remoteUserQId in map (\(c, _) -> (remoteUserId, c)) - (toList (Map.findWithDefault mempty remoteUserQId cm)) + (Map.assocs (Map.findWithDefault mempty remoteUserQId cm)) handleError :: Member TinyLog r => diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/services/galley/src/Galley/API/MLS/Removal.hs index 6f96c071b49..af8cfe9a750 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/services/galley/src/Galley/API/MLS/Removal.hs @@ -25,15 +25,14 @@ where import Data.Id import qualified Data.Map as Map import Data.Qualified -import qualified Data.Set as Set import Data.Time import Galley.API.Error +import Galley.API.MLS.Conversation import Galley.API.MLS.Keys (getMLSRemovalKey) import Galley.API.MLS.Propagate import Galley.API.MLS.Types import qualified Galley.Data.Conversation.Types as Data import Galley.Effects -import Galley.Effects.MemberStore import Galley.Effects.ProposalStore import Galley.Env import Imports @@ -43,6 +42,7 @@ import Polysemy.Input import Polysemy.TinyLog import qualified System.Logger as Log import Wire.API.Conversation.Protocol +import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage import Wire.API.MLS.Message import Wire.API.MLS.Proposal @@ -106,12 +106,11 @@ removeClient :: ClientId -> Sem r () removeClient lc qusr cid = do - for_ (Data.mlsMetadata (tUnqualified lc)) $ \mlsMeta -> do + mMlsConv <- mkMLSConversation (tUnqualified lc) + for_ mMlsConv $ \mlsConv -> do -- FUTUREWORK: also remove the client from from subconversations of lc - cm <- lookupMLSClients (cnvmlsGroupId mlsMeta) - let mlsConv = MLSConversation (tUnqualified lc) mlsMeta cm - let cidAndKP = Set.toList . Set.map snd . Set.filter ((==) cid . fst) $ Map.findWithDefault mempty qusr cm - removeClientsWithClientMap (qualifyAs lc (Conv mlsConv)) cidAndKP qusr + let cidAndKPs = maybeToList (cmLookupRef (mkClientIdentity qusr cid) (mcMembers mlsConv)) + removeClientsWithClientMap (qualifyAs lc (Conv mlsConv)) cidAndKPs qusr -- | Send remove proposals for all clients of the user to the local conversation. removeUser :: @@ -132,8 +131,8 @@ removeUser :: Qualified UserId -> Sem r () removeUser lc qusr = do - for_ (Data.mlsMetadata (tUnqualified lc)) $ \mlsMeta -> do + mMlsConv <- mkMLSConversation (tUnqualified lc) + for_ mMlsConv $ \mlsConv -> do -- FUTUREWORK: also remove the client from from subconversations of lc - cm <- lookupMLSClients (cnvmlsGroupId mlsMeta) - let mlsConv = MLSConversation (tUnqualified lc) mlsMeta cm - removeClientsWithClientMap (qualifyAs lc (Conv mlsConv)) (Set.toList . Set.map snd $ Map.findWithDefault mempty qusr cm) qusr + let kprefs = toList (Map.findWithDefault mempty qusr (mcMembers mlsConv)) + removeClientsWithClientMap (qualifyAs lc (Conv mlsConv)) kprefs qusr diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs index 7446376511b..dfc0234b55b 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -20,23 +20,29 @@ module Galley.API.MLS.SubConversation where import Data.Id import Data.Qualified import Galley.API.Error +import Galley.API.MLS +import Galley.API.MLS.GroupInfo import Galley.API.MLS.Types -import Galley.API.Util (getConversationAndCheckMembership) +import Galley.API.MLS.Util +import Galley.API.Util +import Galley.App (Env) import qualified Galley.Data.Conversation as Data import Galley.Data.Conversation.Types -import Galley.Effects.ConversationStore (ConversationStore) +import Galley.Effects import Galley.Effects.SubConversationStore import qualified Galley.Effects.SubConversationStore as Eff import Imports import qualified Network.Wai.Utilities.Error as Wai import Polysemy import Polysemy.Error +import Polysemy.Input import qualified Polysemy.TinyLog as P import Wire.API.Conversation import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Galley -import Wire.API.Federation.Error (federationNotImplemented) +import Wire.API.Federation.Error (FederationError, federationNotImplemented) +import Wire.API.MLS.PublicGroupState import Wire.API.MLS.SubConversation getSubConversation :: @@ -83,7 +89,7 @@ getLocalSubConversation lusr lconv sconv = do unless (Data.convType c == RegularConv) $ throwS @'MLSSubConvUnsupportedConvType - msub <- Eff.getSubConversation lconv sconv + msub <- Eff.getSubConversation (tUnqualified lconv) sconv sub <- case msub of Nothing -> do mlsMeta <- noteS @'ConvNotFound (mlsMetadata c) @@ -96,7 +102,7 @@ getLocalSubConversation lusr lconv sconv = do setGroupIdForSubConversation groupId (tUntagged lconv) sconv let sub = SubConversation - { scParentConvId = lconv, + { scParentConvId = tUnqualified lconv, scSubConvId = sconv, scMLSData = ConversationMLSData @@ -108,4 +114,44 @@ getLocalSubConversation lusr lconv sconv = do } pure sub Just sub -> pure sub - pure (toPublicSubConv sub) + pure (toPublicSubConv (tUntagged (qualifyAs lusr sub))) + +getSubConversationGroupInfo :: + Members + '[ ConversationStore, + Error FederationError, + FederatorAccess, + Input Env, + MemberStore, + SubConversationStore + ] + r => + Members MLSGroupInfoStaticErrors r => + Local UserId -> + Qualified ConvId -> + SubConvId -> + Sem r OpaquePublicGroupState +getSubConversationGroupInfo lusr qcnvId subconv = do + assertMLSEnabled + foldQualified + lusr + (getSubConversationGroupInfoFromLocalConv (tUntagged lusr) subconv) + (getGroupInfoFromRemoteConv lusr . fmap (flip SubConv subconv)) + qcnvId + +getSubConversationGroupInfoFromLocalConv :: + Members + '[ ConversationStore, + SubConversationStore, + MemberStore + ] + r => + Members MLSGroupInfoStaticErrors r => + Qualified UserId -> + SubConvId -> + Local ConvId -> + Sem r OpaquePublicGroupState +getSubConversationGroupInfoFromLocalConv qusr subConvId lcnvId = do + void $ getLocalConvForUser qusr lcnvId + getSubConversationPublicGroupState (tUnqualified lcnvId) subConvId + >>= noteS @'MLSMissingGroupInfo diff --git a/services/galley/src/Galley/API/MLS/Types.hs b/services/galley/src/Galley/API/MLS/Types.hs index aeee9fe2bc7..ec2643884e3 100644 --- a/services/galley/src/Galley/API/MLS/Types.hs +++ b/services/galley/src/Galley/API/MLS/Types.hs @@ -22,26 +22,36 @@ import Data.Domain import Data.Id import qualified Data.Map as Map import Data.Qualified -import qualified Data.Set as Set -import Galley.Data.Conversation -import qualified Galley.Data.Conversation as Data +import Galley.Types.Conversations.Members import Imports +import Wire.API.Conversation import Wire.API.Conversation.Protocol import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage import Wire.API.MLS.SubConversation -type ClientMap = Map (Qualified UserId) (Set (ClientId, KeyPackageRef)) +type ClientMap = Map (Qualified UserId) (Map ClientId KeyPackageRef) mkClientMap :: [(Domain, UserId, ClientId, KeyPackageRef)] -> ClientMap mkClientMap = foldr addEntry mempty where addEntry :: (Domain, UserId, ClientId, KeyPackageRef) -> ClientMap -> ClientMap addEntry (dom, usr, c, kpr) = - Map.insertWith (<>) (Qualified usr dom) (Set.singleton (c, kpr)) + Map.insertWith (<>) (Qualified usr dom) (Map.singleton c kpr) + +cmLookupRef :: ClientIdentity -> ClientMap -> Maybe KeyPackageRef +cmLookupRef cid cm = do + clients <- Map.lookup (cidQualifiedUser cid) cm + Map.lookup (ciClient cid) clients + +isClientMember :: ClientIdentity -> ClientMap -> Bool +isClientMember ci = isJust . cmLookupRef ci cmAssocs :: ClientMap -> [(Qualified UserId, (ClientId, KeyPackageRef))] -cmAssocs cm = Map.assocs cm >>= traverse toList +cmAssocs cm = do + (quid, clients) <- Map.assocs cm + (clientId, ref) <- Map.assocs clients + pure (quid, (clientId, ref)) -- | Inform a handler for 'POST /conversations/list-ids' if the MLS global team -- conversation and the MLS self-conversation should be included in the @@ -50,25 +60,28 @@ data ListGlobalSelfConvs = ListGlobalSelf | DoNotListGlobalSelf deriving (Eq) data MLSConversation = MLSConversation - { mcConv :: Conversation, + { mcId :: ConvId, + mcMetadata :: ConversationMetadata, mcMLSData :: ConversationMLSData, + mcLocalMembers :: [LocalMember], + mcRemoteMembers :: [RemoteMember], mcMembers :: ClientMap } deriving (Show) data SubConversation = SubConversation - { scParentConvId :: Local ConvId, + { scParentConvId :: ConvId, scSubConvId :: SubConvId, scMLSData :: ConversationMLSData, scMembers :: ClientMap } deriving (Eq, Show) -toPublicSubConv :: SubConversation -> PublicSubConversation -toPublicSubConv SubConversation {..} = +toPublicSubConv :: Qualified SubConversation -> PublicSubConversation +toPublicSubConv (Qualified (SubConversation {..}) domain) = let members = fmap (\(quid, (cid, _kp)) -> mkClientIdentity quid cid) (cmAssocs scMembers) in PublicSubConversation - { pscParentConvId = tUntagged scParentConvId, + { pscParentConvId = Qualified scParentConvId domain, pscSubConvId = scSubConvId, pscGroupId = cnvmlsGroupId scMLSData, pscEpoch = cnvmlsEpoch scMLSData, @@ -91,5 +104,5 @@ convOfConvOrSub (Conv c) = c convOfConvOrSub (SubConv c _) = c idForConvOrSub :: ConvOrSubConv -> ConvOrSubConvId -idForConvOrSub (Conv c) = Conv (Data.convId . mcConv $ c) -idForConvOrSub (SubConv c s) = SubConv (Data.convId . mcConv $ c) (scSubConvId s) +idForConvOrSub (Conv c) = Conv (mcId c) +idForConvOrSub (SubConv c s) = SubConv (mcId c) (scSubConvId s) diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 8d9437f8afc..7de59d5d560 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -49,6 +49,7 @@ conversationAPI = <@> mkNamedAPI @"create-self-conversation" createProteusSelfConversation <@> mkNamedAPI @"get-mls-self-conversation" getMLSSelfConversationWithError <@> mkNamedAPI @"get-subconversation" getSubConversation + <@> mkNamedAPI @"get-subconversation-group-info" getSubConversationGroupInfo <@> mkNamedAPI @"create-one-to-one-conversation@v2" createOne2OneConversation <@> mkNamedAPI @"create-one-to-one-conversation" createOne2OneConversation <@> mkNamedAPI @"add-members-to-conversation-unqualified" addMembersUnqualified diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index 6b9379ad85b..9585f9c038e 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -340,6 +340,9 @@ insertGroupIdForSubConversation = "INSERT INTO group_id_conv_id (group_id, conv_ lookupGroupIdForSubConversation :: PrepQuery R (Identity GroupId) (ConvId, Domain, SubConvId) lookupGroupIdForSubConversation = "SELECT conv_id, domain, subconv_id from group_id_conv_id where group_id = ?" +insertEpochForSubConversation :: PrepQuery W (Epoch, ConvId, SubConvId) () +insertEpochForSubConversation = "UPDATE subconversation set epoch = ? WHERE conv_id = ? AND subconv_id = ?" + -- Members ------------------------------------------------------------------ type MemberStatus = Int32 diff --git a/services/galley/src/Galley/Cassandra/SubConversation.hs b/services/galley/src/Galley/Cassandra/SubConversation.hs index 0216f84ff7a..259255ffe1a 100644 --- a/services/galley/src/Galley/Cassandra/SubConversation.hs +++ b/services/galley/src/Galley/Cassandra/SubConversation.hs @@ -34,9 +34,9 @@ import Wire.API.MLS.Group import Wire.API.MLS.PublicGroupState import Wire.API.MLS.SubConversation -selectSubConversation :: Local ConvId -> SubConvId -> Client (Maybe SubConversation) +selectSubConversation :: ConvId -> SubConvId -> Client (Maybe SubConversation) selectSubConversation convId subConvId = do - m <- retry x5 (query1 Cql.selectSubConversation (params LocalQuorum (tUnqualified convId, subConvId))) + m <- retry x5 (query1 Cql.selectSubConversation (params LocalQuorum (convId, subConvId))) for m $ \(suite, epoch, groupId) -> do cm <- lookupMLSClients groupId pure $ @@ -68,6 +68,10 @@ setGroupIdForSubConversation :: GroupId -> Qualified ConvId -> SubConvId -> Clie setGroupIdForSubConversation groupId qconv sconv = retry x5 (write Cql.insertGroupIdForSubConversation (params LocalQuorum (groupId, qUnqualified qconv, qDomain qconv, sconv))) +setEpochForSubConversation :: ConvId -> SubConvId -> Epoch -> Client () +setEpochForSubConversation cid sconv epoch = + retry x5 (write Cql.insertEpochForSubConversation (params LocalQuorum (epoch, cid, sconv))) + interpretSubConversationStoreToCassandra :: Members '[Embed IO, Input ClientState] r => Sem (SubConversationStore ': r) a -> @@ -78,3 +82,4 @@ interpretSubConversationStoreToCassandra = interpret $ \case SetSubConversationPublicGroupState convId subConvId mPgs -> embedClient (updateSubConvPublicGroupState convId subConvId mPgs) GetSubConversationPublicGroupState convId subConvId -> embedClient (selectSubConvPublicGroupState convId subConvId) SetGroupIdForSubConversation gId cid sconv -> embedClient $ setGroupIdForSubConversation gId cid sconv + SetSubConversationEpoch cid sconv epoch -> embedClient $ setEpochForSubConversation cid sconv epoch diff --git a/services/galley/src/Galley/Effects/MemberStore.hs b/services/galley/src/Galley/Effects/MemberStore.hs index f9f5b57d505..ec865b8e273 100644 --- a/services/galley/src/Galley/Effects/MemberStore.hs +++ b/services/galley/src/Galley/Effects/MemberStore.hs @@ -50,6 +50,7 @@ where import Data.Id import Data.Qualified +import Galley.API.MLS.Types import Galley.Data.Services import Galley.Types.Conversations.Members import Galley.Types.ToUserRole @@ -77,9 +78,7 @@ data MemberStore m a where DeleteMembersInRemoteConversation :: Remote ConvId -> [UserId] -> MemberStore m () AddMLSClients :: GroupId -> Qualified UserId -> Set (ClientId, KeyPackageRef) -> MemberStore m () RemoveMLSClients :: GroupId -> Qualified UserId -> Set ClientId -> MemberStore m () - LookupMLSClients :: - GroupId -> - MemberStore m (Map (Qualified UserId) (Set (ClientId, KeyPackageRef))) + LookupMLSClients :: GroupId -> MemberStore m ClientMap makeSem ''MemberStore diff --git a/services/galley/src/Galley/Effects/SubConversationStore.hs b/services/galley/src/Galley/Effects/SubConversationStore.hs index 46d90b34287..00120d40c38 100644 --- a/services/galley/src/Galley/Effects/SubConversationStore.hs +++ b/services/galley/src/Galley/Effects/SubConversationStore.hs @@ -31,10 +31,11 @@ import Wire.API.MLS.PublicGroupState import Wire.API.MLS.SubConversation data SubConversationStore m a where - GetSubConversation :: Local ConvId -> SubConvId -> SubConversationStore m (Maybe SubConversation) + GetSubConversation :: ConvId -> SubConvId -> SubConversationStore m (Maybe SubConversation) CreateSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> Epoch -> GroupId -> Maybe OpaquePublicGroupState -> SubConversationStore m () SetSubConversationPublicGroupState :: ConvId -> SubConvId -> Maybe OpaquePublicGroupState -> SubConversationStore m () GetSubConversationPublicGroupState :: ConvId -> SubConvId -> SubConversationStore m (Maybe OpaquePublicGroupState) SetGroupIdForSubConversation :: GroupId -> Qualified ConvId -> SubConvId -> SubConversationStore m () + SetSubConversationEpoch :: ConvId -> SubConvId -> Epoch -> SubConversationStore m () makeSem ''SubConversationStore diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 3f11bad6d6d..10df04b4930 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -208,7 +208,13 @@ tests s = testGroup "SubConversation" [ test s "get subconversation of MLS conv - 200" (testCreateSubConv True), - test s "get subconversation of Proteus conv - 404" (testCreateSubConv False) + test s "get subconversation of Proteus conv - 404" (testCreateSubConv False), + test s "join subconversation with an external commit bundle" testJoinSubConv, + test s "join subconversation with a client that is not in the main conv" testJoinSubNonMemberClient, + test s "add another client to a subconversation" testAddClientSubConv, + test s "remove another client from a subconversation" testRemoveClientSubConv, + test s "join remote subconversation" testJoinRemoteSubConv, + test s "client of a remote user joins subconversation" testRemoteUserJoinSubConv ] ] @@ -372,7 +378,7 @@ testAddUserWithBundle = do returnedGS <- fmap responseBody $ - getGroupInfo (qUnqualified alice) qcnv + getGroupInfo (qUnqualified alice) (fmap Conv qcnv) returnedGS @@ -990,8 +996,8 @@ testExternalCommitNotMember = do pgs <- LBS.toStrict . fromJust . responseBody - <$> getGroupInfo (ciUser alice1) qcnv - mp <- createExternalCommit bob1 (Just pgs) qcnv + <$> getGroupInfo (ciUser alice1) (fmap Conv qcnv) + mp <- createExternalCommit bob1 (Just pgs) (fmap Conv qcnv) bundle <- createBundle mp postCommitBundle (mpSender mp) bundle !!! const 404 === statusCode @@ -1007,7 +1013,9 @@ testExternalCommitSameClient = do void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle let rejoiner = alice1 - ecEvents <- createExternalCommit rejoiner Nothing qcnv >>= sendAndConsumeCommitBundle + ecEvents <- + createExternalCommit rejoiner Nothing (fmap Conv qcnv) + >>= sendAndConsumeCommitBundle liftIO $ assertBool "No events after external commit expected" (null ecEvents) @@ -1025,7 +1033,9 @@ testExternalCommitNewClient = do void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle nc <- createMLSClient bob - ecEvents <- createExternalCommit nc Nothing qcnv >>= sendAndConsumeCommitBundle + ecEvents <- + createExternalCommit nc Nothing (fmap Conv qcnv) + >>= sendAndConsumeCommitBundle liftIO $ assertBool "No events after external commit expected" (null ecEvents) @@ -1075,7 +1085,7 @@ testExternalCommitNewClientResendBackendProposal = do WS.assertMatchN_ (5 # WS.Second) [wsA, wsB] $ void . wsAssertAddProposal bob qcnv - mp <- createExternalCommit bob4 Nothing qcnv + mp <- createExternalCommit bob4 Nothing (fmap Conv qcnv) ecEvents <- sendAndConsumeCommitBundle mp liftIO $ assertBool "No events after external commit expected" (null ecEvents) @@ -1941,7 +1951,7 @@ testGetGroupInfoOfLocalConv = do gs <- assertJust (mpPublicGroupState commit) returnedGS <- fmap responseBody $ - getGroupInfo (qUnqualified alice) qcnv + getGroupInfo (qUnqualified alice) (fmap Conv qcnv) returnedGS @@ -1975,10 +1985,10 @@ testGetGroupInfoOfRemoteConv = do (_, reqs) <- withTempMockFederator' mock $ do res <- fmap responseBody $ - getGroupInfo (qUnqualified bob) qcnv + getGroupInfo (qUnqualified bob) (fmap Conv qcnv) assertFailure ("Unexpected error: " <> show err) @@ -2034,7 +2044,7 @@ testFederatedGetGroupInfo = do @"query-group-info" fedGalleyClient (ciDomain bob1) - (GetGroupInfoRequest (qUnqualified qcnv) (qUnqualified charlie)) + (GetGroupInfoRequest (Conv (qUnqualified qcnv)) (qUnqualified charlie)) liftIO $ case resp of GetGroupInfoResponseError err -> @@ -2279,7 +2289,7 @@ getGroupInfoDisabled = do void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit withMLSDisabled $ - getGroupInfo (qUnqualified alice) qcnv + getGroupInfo (qUnqualified alice) (fmap Conv qcnv) !!! assertMLSNotEnabled testCreateSubConv :: Bool -> TestM () @@ -2295,8 +2305,54 @@ testCreateSubConv parentIsMLSConv = do else cnvQualifiedId <$> liftTest (postConvQualified (qUnqualified alice) defNewProteusConv >>= responseJsonError) - let sconv = SubConvId "call" + let sconv = SubConvId "conference" liftTest $ getSubConv (qUnqualified alice) qcnv sconv !!! do const (if parentIsMLSConv then 200 else 404) === statusCode + +testJoinSubConv :: TestM () +testJoinSubConv = do + [alice, bob] <- createAndConnectUsers [Nothing, Nothing] + + runMLSTest $ + do + [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + traverse_ uploadNewKeyPackage [bob1, bob2] + (_, qcnv) <- setupMLSGroup alice1 + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + + let subId = SubConvId "conference" + sub <- + liftTest $ + responseJsonError + =<< getSubConv (qUnqualified bob) qcnv (SubConvId "conference") + >= sendAndConsumeCommitBundle + + -- now alice joins with her own client + void $ + createExternalCommit alice1 Nothing (fmap (flip SubConv subId) qcnv) + >>= sendAndConsumeCommitBundle + +-- FUTUREWORK: implement the following tests + +testJoinSubNonMemberClient :: TestM () +testJoinSubNonMemberClient = pure () + +testAddClientSubConv :: TestM () +testAddClientSubConv = pure () + +testRemoveClientSubConv :: TestM () +testRemoveClientSubConv = pure () + +testJoinRemoteSubConv :: TestM () +testJoinRemoteSubConv = pure () + +testRemoteUserJoinSubConv :: TestM () +testRemoteUserJoinSubConv = pure () diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 6174b09abe4..df6839f7f3e 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -444,14 +444,19 @@ createGroup cid gid = do State.gets mlsGroupId >>= \case Just _ -> liftIO $ assertFailure "only one group can be created" Nothing -> pure () + resetGroup cid gid +resetGroup :: ClientIdentity -> GroupId -> MLSTest () +resetGroup cid gid = do groupJSON <- mlscli cid ["group", "create", T.unpack (toBase64Text (unGroupId gid))] Nothing g <- nextGroupFile cid liftIO $ BS.writeFile g groupJSON State.modify $ \s -> s { mlsGroupId = Just gid, - mlsMembers = Set.singleton cid + mlsMembers = Set.singleton cid, + mlsEpoch = 0, + mlsNewMembers = mempty } -- | Create a local group only without a conversation. This simulates creating @@ -546,16 +551,18 @@ createExternalCommit :: HasCallStack => ClientIdentity -> Maybe ByteString -> - Qualified ConvId -> + Qualified ConvOrSubConvId -> MLSTest MessagePackage -createExternalCommit qcid mpgs qcnv = do +createExternalCommit qcid mpgs qcs = do bd <- State.gets mlsBaseDir gNew <- nextGroupFile qcid pgsFile <- liftIO $ emptyTempFile bd "pgs" pgs <- case mpgs of Nothing -> LBS.toStrict . fromJust . responseBody - <$> getGroupInfo (ciUser qcid) qcnv + <$> ( getGroupInfo (ciUser qcid) qcs + pure v commit <- mlscli @@ -1011,21 +1018,37 @@ getGroupInfo :: HasGalley m ) => UserId -> - Qualified ConvId -> + Qualified ConvOrSubConvId -> m ResponseLBS -getGroupInfo sender qcnv = do +getGroupInfo sender qcs = do galley <- viewGalley - get - ( galley - . paths - [ "conversations", - toByteString' (qDomain qcnv), - toByteString' (qUnqualified qcnv), - "groupinfo" - ] - . zUser sender - . zConn "conn" - ) + case qUnqualified qcs of + Conv cnv -> + get + ( galley + . paths + [ "conversations", + toByteString' (qDomain qcs), + toByteString' cnv, + "groupinfo" + ] + . zUser sender + . zConn "conn" + ) + SubConv cnv sub -> + get + ( galley + . paths + [ "conversations", + toByteString' (qDomain qcs), + toByteString' cnv, + "subconversations", + toByteString' sub, + "groupinfo" + ] + . zUser sender + . zConn "conn" + ) getSelfConv :: UserId ->