diff --git a/cassandra-schema.cql b/cassandra-schema.cql index e9e0b6c8b9..0cccd7f520 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -348,7 +348,8 @@ CREATE TABLE galley_test.legalhold_pending_prekeys ( CREATE TABLE galley_test.group_id_conv_id ( group_id blob PRIMARY KEY, conv_id uuid, - domain text + domain text, + subconv_id text ) WITH bloom_filter_fp_chance = 0.01 AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} AND comment = '' @@ -524,6 +525,30 @@ CREATE TABLE galley_test.mls_commit_locks ( AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; +CREATE TABLE galley_test.subconversation ( + conv_id uuid, + subconv_id text, + cipher_suite int, + epoch bigint, + group_id blob, + public_group_state blob, + PRIMARY KEY (conv_id, subconv_id) +) WITH CLUSTERING ORDER BY (subconv_id ASC) + AND bloom_filter_fp_chance = 0.01 + AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} + AND comment = '' + AND compaction = {'class': 'org.apache.cassandra.db.compaction.SizeTieredCompactionStrategy', 'max_threshold': '32', 'min_threshold': '4'} + AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} + AND crc_check_chance = 1.0 + AND dclocal_read_repair_chance = 0.1 + AND default_time_to_live = 0 + AND gc_grace_seconds = 864000 + AND max_index_interval = 2048 + AND memtable_flush_period_in_ms = 0 + AND min_index_interval = 128 + AND read_repair_chance = 0.0 + AND speculative_retry = '99PERCENTILE'; + CREATE TABLE galley_test.team ( team uuid PRIMARY KEY, binding boolean, diff --git a/changelog.d/1-api-changes/get-subconversation b/changelog.d/1-api-changes/get-subconversation new file mode 100644 index 0000000000..175ddb4b90 --- /dev/null +++ b/changelog.d/1-api-changes/get-subconversation @@ -0,0 +1 @@ +Introduce a subconversation GET endpoint diff --git a/changelog.d/5-internal/galley-db-subconv b/changelog.d/5-internal/galley-db-subconv new file mode 100644 index 0000000000..d57f71df5a --- /dev/null +++ b/changelog.d/5-internal/galley-db-subconv @@ -0,0 +1 @@ +Introduce a Galley DB table for subconversations diff --git a/changelog.d/5-internal/group-id-subconv b/changelog.d/5-internal/group-id-subconv new file mode 100644 index 0000000000..2706db951b --- /dev/null +++ b/changelog.d/5-internal/group-id-subconv @@ -0,0 +1 @@ +Support mapping MLS group IDs to subconversations diff --git a/changelog.d/5-internal/subconv-store b/changelog.d/5-internal/subconv-store new file mode 100644 index 0000000000..ef3798fdc6 --- /dev/null +++ b/changelog.d/5-internal/subconv-store @@ -0,0 +1 @@ +Introduce an effect for subconversations diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index 65596d70fa..d61666ec6e 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -85,6 +85,8 @@ data GalleyError | MLSWelcomeMismatch | MLSMissingGroupInfo | MLSMissingSenderClient + | MLSUnexpectedSenderClient + | MLSSubConvUnsupportedConvType | -- NoBindingTeamMembers | NoBindingTeam @@ -217,6 +219,8 @@ type instance MapError 'MLSMissingGroupInfo = 'StaticError 404 "mls-missing-grou type instance MapError 'MLSMissingSenderClient = 'StaticError 403 "mls-missing-sender-client" "The client has to refresh their access token and provide their client ID" +type instance MapError 'MLSSubConvUnsupportedConvType = 'StaticError 403 "mls-subconv-unsupported-convtype" "MLS subconversations are only supported for regular conversations" + type instance MapError 'NoBindingTeamMembers = 'StaticError 403 "non-binding-team-members" "Both users must be members of the same binding team" type instance MapError 'NoBindingTeam = 'StaticError 403 "no-binding-team" "Operation allowed only on binding teams" diff --git a/libs/wire-api/src/Wire/API/MLS/SubConversation.hs b/libs/wire-api/src/Wire/API/MLS/SubConversation.hs index e867b555e0..a0d3ccf386 100644 --- a/libs/wire-api/src/Wire/API/MLS/SubConversation.hs +++ b/libs/wire-api/src/Wire/API/MLS/SubConversation.hs @@ -20,17 +20,26 @@ module Wire.API.MLS.SubConversation where -import Control.Lens (makePrisms) +import Control.Lens (makePrisms, (?~)) import Control.Lens.Tuple (_1) import Control.Monad.Except +import qualified Crypto.Hash as Crypto import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson as A +import Data.ByteArray +import Data.ByteString.Conversion import Data.Id +import Data.Qualified import Data.Schema import qualified Data.Swagger as S import qualified Data.Text as T import Imports import Servant (FromHttpApiData (..), ToHttpApiData (toQueryParam)) import Test.QuickCheck +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Credential +import Wire.API.MLS.Epoch +import Wire.API.MLS.Group import Wire.Arbitrary -- | An MLS subconversation ID, which identifies a subconversation within a @@ -54,6 +63,40 @@ instance FromHttpApiData SubConvId where instance ToHttpApiData SubConvId where toQueryParam = unSubConvId +-- | Compute the inital group ID for a subconversation +initialGroupId :: Local ConvId -> SubConvId -> GroupId +initialGroupId lcnv sconv = + GroupId + . convert + . Crypto.hash @ByteString @Crypto.SHA256 + $ toByteString' (tUnqualified lcnv) + <> toByteString' (tDomain lcnv) + <> toByteString' (unSubConvId sconv) + +data PublicSubConversation = PublicSubConversation + { pscParentConvId :: Qualified ConvId, + pscSubConvId :: SubConvId, + pscGroupId :: GroupId, + pscEpoch :: Epoch, + pscCipherSuite :: CipherSuiteTag, + pscMembers :: [ClientIdentity] + } + deriving (Eq, Show) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema PublicSubConversation) + +instance ToSchema PublicSubConversation where + schema = + objectWithDocModifier + "PublicSubConversation" + (description ?~ "A MLS subconversation") + $ PublicSubConversation + <$> pscParentConvId .= field "parent_qualified_id" schema + <*> pscSubConvId .= field "subconv_id" schema + <*> pscGroupId .= field "group_id" schema + <*> pscEpoch .= field "epoch" schema + <*> pscCipherSuite .= field "cipher_suite" schema + <*> pscMembers .= field "members" (array schema) + data ConvOrSubTag = ConvTag | SubConvTag deriving (Eq, Enum, Bounded) 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 023963c96c..1fcc514df1 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 @@ -32,6 +32,7 @@ import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.MLS.PublicGroupState import Wire.API.MLS.Servant +import Wire.API.MLS.SubConversation import Wire.API.Routes.MultiVerb import Wire.API.Routes.Named import Wire.API.Routes.Public @@ -375,6 +376,26 @@ type ConversationAPI = Conversation ) ) + :<|> Named + "get-subconversation" + ( Summary "Get information about an MLS subconversation" + :> CanThrow 'ConvNotFound + :> CanThrow 'ConvAccessDenied + :> CanThrow 'MLSSubConvUnsupportedConvType + :> ZLocalUser + :> "conversations" + :> QualifiedCapture "cnv" ConvId + :> "subconversations" + :> Capture "subconv" SubConvId + :> MultiVerb1 + 'GET + '[JSON] + ( Respond + 200 + "Subconversation" + PublicSubConversation + ) + ) -- 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/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs index eddafd7649..a7f7474143 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs @@ -33,6 +33,7 @@ import Test.Wire.API.Golden.Manual.GroupId import Test.Wire.API.Golden.Manual.ListConversations import Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap import Test.Wire.API.Golden.Manual.SearchResultContact +import Test.Wire.API.Golden.Manual.SubConversation import Test.Wire.API.Golden.Manual.TeamSize import Test.Wire.API.Golden.Manual.Token import Test.Wire.API.Golden.Manual.UserClientPrekeyMap @@ -139,5 +140,10 @@ tests = [ (testObject_TeamSize_1, "testObject_TeamSize_1.json"), (testObject_TeamSize_2, "testObject_TeamSize_2.json"), (testObject_TeamSize_3, "testObject_TeamSize_3.json") + ], + testGroup "PublicSubConversation" $ + testObjects + [ (testObject_PublicSubConversation_1, "testObject_PublicSubConversation_1.json"), + (testObject_PublicSubConversation_2, "testObject_PublicSubConversation_2.json") ] ] diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/SubConversation.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/SubConversation.hs new file mode 100644 index 0000000000..640dde1c77 --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/SubConversation.hs @@ -0,0 +1,77 @@ +-- 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 Test.Wire.API.Golden.Manual.SubConversation + ( testObject_PublicSubConversation_1, + testObject_PublicSubConversation_2, + ) +where + +import Data.Domain +import Data.Id +import Data.Qualified +import qualified Data.UUID as UUID +import Imports +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Credential +import Wire.API.MLS.Epoch +import Wire.API.MLS.Group +import Wire.API.MLS.SubConversation + +subConvId1 :: SubConvId +subConvId1 = SubConvId "test_group" + +subConvId2 :: SubConvId +subConvId2 = SubConvId "call" + +domain :: Domain +domain = Domain "golden.example.com" + +convId :: Qualified ConvId +convId = + Qualified + ( Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001")) + ) + domain + +testObject_PublicSubConversation_1 :: PublicSubConversation +testObject_PublicSubConversation_1 = + PublicSubConversation + convId + subConvId1 + (GroupId "test_group") + (Epoch 5) + MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + [] + +testObject_PublicSubConversation_2 :: PublicSubConversation +testObject_PublicSubConversation_2 = + PublicSubConversation + convId + subConvId2 + (GroupId "test_group_2") + (Epoch 0) + MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + [mkClientIdentity user cid] + where + user :: Qualified UserId + user = + Qualified + ( Id (fromJust (UUID.fromString "00000000-0000-0007-0000-000a00000002")) + ) + domain + cid = ClientId "deadbeef" diff --git a/libs/wire-api/test/golden/testObject_PublicSubConversation_1.json b/libs/wire-api/test/golden/testObject_PublicSubConversation_1.json new file mode 100644 index 0000000000..d81e3853f4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_PublicSubConversation_1.json @@ -0,0 +1,11 @@ +{ + "cipher_suite": 1, + "epoch": 5, + "group_id": "dGVzdF9ncm91cA==", + "members": [], + "parent_qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "subconv_id": "test_group" +} diff --git a/libs/wire-api/test/golden/testObject_PublicSubConversation_2.json b/libs/wire-api/test/golden/testObject_PublicSubConversation_2.json new file mode 100644 index 0000000000..ac57e7e8e1 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_PublicSubConversation_2.json @@ -0,0 +1,17 @@ +{ + "cipher_suite": 1, + "epoch": 0, + "group_id": "dGVzdF9ncm91cF8y", + "members": [ + { + "client_id": "deadbeef", + "domain": "golden.example.com", + "user_id": "00000000-0000-0007-0000-000a00000002" + } + ], + "parent_qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "subconv_id": "call" +} diff --git a/libs/wire-api/test/unit/Main.hs b/libs/wire-api/test/unit/Main.hs index 46178a1d7a..e90bd6b3fe 100644 --- a/libs/wire-api/test/unit/Main.hs +++ b/libs/wire-api/test/unit/Main.hs @@ -25,6 +25,7 @@ import Test.Tasty import qualified Test.Wire.API.Call.Config as Call.Config import qualified Test.Wire.API.Conversation as Conversation import qualified Test.Wire.API.MLS as MLS +import qualified Test.Wire.API.MLS.SubConversation as SubConversation import qualified Test.Wire.API.Roundtrip.Aeson as Roundtrip.Aeson import qualified Test.Wire.API.Roundtrip.ByteString as Roundtrip.ByteString import qualified Test.Wire.API.Roundtrip.CSV as Roundtrip.CSV @@ -59,5 +60,6 @@ main = Roundtrip.CSV.tests, Routes.tests, Conversation.tests, - MLS.tests + MLS.tests, + SubConversation.tests ] diff --git a/libs/wire-api/test/unit/Test/Wire/API/MLS/SubConversation.hs b/libs/wire-api/test/unit/Test/Wire/API/MLS/SubConversation.hs new file mode 100644 index 0000000000..6783346756 --- /dev/null +++ b/libs/wire-api/test/unit/Test/Wire/API/MLS/SubConversation.hs @@ -0,0 +1,46 @@ +-- 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 Test.Wire.API.MLS.SubConversation where + +import Data.Domain +import Data.Id +import Data.Qualified +import Imports +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck +import Wire.API.MLS.SubConversation + +tests :: TestTree +tests = + testGroup + "Subconversation" + [ testProperty "injectivity of the initial group ID mapping" $ + forAll genIds injectiveInitialGroupId + ] + where + genIds :: Gen (ConvId, SubConvId, SubConvId) + genIds = do + s1 <- arbitrary + (,,) <$> arbitrary <*> pure s1 <*> arbitrary `suchThat` (/= s1) + +injectiveInitialGroupId :: (ConvId, SubConvId, SubConvId) -> Property +injectiveInitialGroupId (cnv, scnv1, scnv2) = do + let domain = Domain "group.example.com" + lcnv = toLocalUnsafe domain cnv + initialGroupId lcnv scnv1 =/= initialGroupId lcnv scnv2 diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 0ec71019ec..9cc7cafecd 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -530,6 +530,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Manual.ListConversations Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap Test.Wire.API.Golden.Manual.SearchResultContact + Test.Wire.API.Golden.Manual.SubConversation Test.Wire.API.Golden.Manual.TeamSize Test.Wire.API.Golden.Manual.Token Test.Wire.API.Golden.Manual.UserClientPrekeyMap @@ -640,6 +641,7 @@ test-suite wire-api-tests Test.Wire.API.Call.Config Test.Wire.API.Conversation Test.Wire.API.MLS + Test.Wire.API.MLS.SubConversation Test.Wire.API.Roundtrip.Aeson Test.Wire.API.Roundtrip.ByteString Test.Wire.API.Roundtrip.CSV diff --git a/services/galley/default.nix b/services/galley/default.nix index cf8abcd206..f2a502882f 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -46,6 +46,7 @@ , HsOpenSSL , HsOpenSSL-x509-system , hspec +, http-api-data , http-client , http-client-openssl , http-client-tls @@ -276,6 +277,7 @@ mkDerivation { HsOpenSSL HsOpenSSL-x509-system hspec + http-api-data http-client http-client-openssl http-client-tls diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 69cb442338..346c984e7d 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -38,6 +38,7 @@ library Galley.API.MLS.Message Galley.API.MLS.Propagate Galley.API.MLS.Removal + Galley.API.MLS.SubConversation Galley.API.MLS.Types Galley.API.MLS.Util Galley.API.MLS.Welcome @@ -79,6 +80,7 @@ library Galley.Cassandra.SearchVisibility Galley.Cassandra.Services Galley.Cassandra.Store + Galley.Cassandra.SubConversation Galley.Cassandra.Team Galley.Cassandra.TeamFeatures Galley.Cassandra.TeamNotifications @@ -108,6 +110,7 @@ library Galley.Effects.SearchVisibilityStore Galley.Effects.ServiceStore Galley.Effects.SparAccess + Galley.Effects.SubConversationStore Galley.Effects.TeamFeatureStore Galley.Effects.TeamMemberStore Galley.Effects.TeamNotificationStore @@ -473,6 +476,7 @@ executable galley-integration , HsOpenSSL , HsOpenSSL-x509-system , hspec + , http-api-data , http-client , http-client-openssl , http-client-tls @@ -692,6 +696,7 @@ executable galley-schema V75_MLSGroupInfo V76_ProposalOrigin V77_MLSGroupMemberClient + V78_MLSSubconversation hs-source-dirs: schema/src default-extensions: diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index bb3642744b..33f3f719a1 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -80,6 +80,7 @@ import qualified V74_ExposeInvitationsToTeamAdmin import qualified V75_MLSGroupInfo import qualified V76_ProposalOrigin import qualified V77_MLSGroupMemberClient +import qualified V78_MLSSubconversation main :: IO () main = do @@ -145,7 +146,8 @@ main = do V74_ExposeInvitationsToTeamAdmin.migration, V75_MLSGroupInfo.migration, V76_ProposalOrigin.migration, - V77_MLSGroupMemberClient.migration + V77_MLSGroupMemberClient.migration, + V78_MLSSubconversation.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Galley.Cassandra -- (see also docs/developer/cassandra-interaction.md) diff --git a/services/galley/schema/src/V78_MLSSubconversation.hs b/services/galley/schema/src/V78_MLSSubconversation.hs new file mode 100644 index 0000000000..f83ec0bc1e --- /dev/null +++ b/services/galley/schema/src/V78_MLSSubconversation.hs @@ -0,0 +1,42 @@ +-- 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 V78_MLSSubconversation (migration) where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = + Migration 78 "Add the MLS subconversation tables" $ do + schema' + [r| CREATE TABLE subconversation ( + conv_id uuid, + subconv_id text, + group_id blob, + cipher_suite int, + public_group_state blob, + epoch bigint, + PRIMARY KEY (conv_id, subconv_id) + ); + |] + schema' + [r| ALTER TABLE group_id_conv_id ADD ( + subconv_id text + ); + |] diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 870c51b658..dbf85df914 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -57,6 +57,7 @@ import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.FireAndForget as E import qualified Galley.Effects.MemberStore as E import Galley.Effects.ProposalStore (ProposalStore) +import Galley.Effects.SubConversationStore import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.UserList (UserList (UserList)) @@ -90,7 +91,6 @@ 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 @@ -202,7 +202,7 @@ onNewRemoteConversation :: onNewRemoteConversation domain nrc = do -- update group_id -> conv_id mapping for_ (preview (to F.nrcProtocol . _ProtocolMLS) nrc) $ \mls -> - E.setGroupId (cnvmlsGroupId mls) (Qualified (F.nrcConvId nrc) domain) + E.setGroupIdForConversation (cnvmlsGroupId mls) (Qualified (F.nrcConvId nrc) domain) pure EmptyResponse @@ -601,24 +601,25 @@ updateConversation origDomain updateRequest = do sendMLSCommitBundle :: ( Members - [ BrigAccess, - ConversationStore, - ExternalAccess, - Error FederationError, - Error InternalError, - FederatorAccess, - GundeckAccess, - Input (Local ()), - Input Env, - Input Opts, - Input UTCTime, - LegalHoldStore, - MemberStore, - Resource, - TeamStore, - P.TinyLog, - ProposalStore - ] + '[ BrigAccess, + ConversationStore, + Error FederationError, + Error InternalError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + Input Env, + Input (Local ()), + Input Opts, + Input UTCTime, + LegalHoldStore, + MemberStore, + ProposalStore, + P.TinyLog, + Resource, + SubConversationStore, + TeamStore + ] r ) => Domain -> @@ -638,10 +639,10 @@ sendMLSCommitBundle remoteDomain msr = let sender = toRemoteUnsafe remoteDomain (F.mmsrSender msr) bundle <- either (throw . mlsProtocolError) pure $ deserializeCommitBundle (fromBase64ByteString (F.mmsrRawMessage msr)) let msg = rmValue (cbCommitMsg bundle) - qcnv <- E.getConversationIdByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound - when (Conv (qUnqualified qcnv) /= F.mmsrConvOrSubId msr) $ throwS @'MLSGroupConversationMismatch + qConvOrSub <- E.lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound + when (qUnqualified qConvOrSub /= F.mmsrConvOrSubId msr) $ throwS @'MLSGroupConversationMismatch F.MLSMessageResponseUpdates . map lcuUpdate - <$> postMLSCommitBundle loc (tUntagged sender) Nothing qcnv Nothing bundle + <$> postMLSCommitBundle loc (tUntagged sender) Nothing qConvOrSub Nothing bundle sendMLSMessage :: ( Members @@ -659,6 +660,7 @@ sendMLSMessage :: LegalHoldStore, MemberStore, Resource, + SubConversationStore, TeamStore, P.TinyLog, ProposalStore @@ -683,10 +685,10 @@ sendMLSMessage remoteDomain msr = raw <- either (throw . mlsProtocolError) pure $ decodeMLS' (fromBase64ByteString (F.mmsrRawMessage msr)) case rmValue raw of SomeMessage _ msg -> do - qcnv <- E.getConversationIdByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound - when (Conv (qUnqualified qcnv) /= F.mmsrConvOrSubId msr) $ throwS @'MLSGroupConversationMismatch + qConvOrSub <- E.lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound + when (qUnqualified qConvOrSub /= F.mmsrConvOrSubId msr) $ throwS @'MLSGroupConversationMismatch F.MLSMessageResponseUpdates . map lcuUpdate - <$> postMLSMessage loc (tUntagged sender) Nothing qcnv Nothing raw + <$> postMLSMessage loc (tUntagged sender) Nothing qConvOrSub Nothing raw class ToGalleyRuntimeError (effs :: EffectRow) r where mapToGalleyError :: diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 16fb3e71a4..4e90800547 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -56,6 +56,7 @@ import Galley.Effects.ConversationStore import Galley.Effects.FederatorAccess import Galley.Effects.MemberStore import Galley.Effects.ProposalStore +import Galley.Effects.SubConversationStore import Galley.Env import Galley.Options import Galley.Types.Conversations.Members @@ -138,6 +139,7 @@ postMLSMessageFromLocalUserV1 :: Input (Local ()), ProposalStore, Resource, + SubConversationStore, TinyLog ] r @@ -151,9 +153,9 @@ postMLSMessageFromLocalUserV1 lusr mc conn smsg = do assertMLSEnabled case rmValue smsg of SomeMessage _ msg -> do - qcnv <- getConversationIdByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound + cnvOrSub <- lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound map lcuEvent - <$> postMLSMessage lusr (tUntagged lusr) mc qcnv (Just conn) smsg + <$> postMLSMessage lusr (tUntagged lusr) mc cnvOrSub (Just conn) smsg postMLSMessageFromLocalUser :: ( HasProposalEffects r, @@ -176,6 +178,7 @@ postMLSMessageFromLocalUser :: Input (Local ()), ProposalStore, Resource, + SubConversationStore, TinyLog ] r @@ -207,6 +210,7 @@ postMLSCommitBundle :: MemberStore, ProposalStore, Resource, + SubConversationStore, TinyLog ] r @@ -214,16 +218,16 @@ postMLSCommitBundle :: Local x -> Qualified UserId -> Maybe ClientId -> - Qualified ConvId -> + Qualified ConvOrSubConvId -> Maybe ConnId -> CommitBundle -> Sem r [LocalConversationUpdate] -postMLSCommitBundle loc qusr mc qcnv conn rawBundle = +postMLSCommitBundle loc qusr mc qConvOrSub conn rawBundle = foldQualified loc (postMLSCommitBundleToLocalConv qusr mc conn rawBundle) (postMLSCommitBundleToRemoteConv loc qusr conn rawBundle) - qcnv + qConvOrSub postMLSCommitBundleFromLocalUser :: ( HasProposalEffects r, @@ -239,6 +243,7 @@ postMLSCommitBundleFromLocalUser :: MemberStore, ProposalStore, Resource, + SubConversationStore, TinyLog ] r @@ -251,10 +256,10 @@ postMLSCommitBundleFromLocalUser :: postMLSCommitBundleFromLocalUser lusr mc conn bundle = do assertMLSEnabled let msg = rmValue (cbCommitMsg bundle) - qcnv <- getConversationIdByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound + qConvOrSub <- lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound events <- map lcuEvent - <$> postMLSCommitBundle lusr (tUntagged lusr) mc qcnv (Just conn) bundle + <$> postMLSCommitBundle lusr (tUntagged lusr) mc qConvOrSub (Just conn) bundle t <- toUTCTimeMillis <$> input pure $ MLSMessageSendingStatus events t @@ -268,8 +273,10 @@ postMLSCommitBundleToLocalConv :: Error MLSProtocolError, Input Opts, Input UTCTime, + MemberStore, ProposalStore, Resource, + SubConversationStore, TinyLog ] r @@ -278,22 +285,19 @@ postMLSCommitBundleToLocalConv :: Maybe ClientId -> Maybe ConnId -> CommitBundle -> - Local ConvId -> + Local ConvOrSubConvId -> Sem r [LocalConversationUpdate] -postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do - let msg = rmValue (cbCommitMsg bundle) - conv <- getLocalConvForUser qusr lcnv - mlsMeta <- Data.mlsMetadata conv & noteS @'ConvNotFound +postMLSCommitBundleToLocalConv qusr mc conn bundle lConvOrSubId = do + lConvOrSub <- fetchConvOrSub qusr lConvOrSubId - let lconv = qualifyAs lcnv conv - cm <- lookupMLSClients (cnvmlsGroupId mlsMeta) + let msg = rmValue (cbCommitMsg bundle) senderClient <- fmap ciClient <$> getSenderIdentity qusr mc SMLSPlainText msg events <- case msgPayload msg of CommitMessage commit -> do - action <- getCommitData lconv mlsMeta (msgEpoch msg) commit + action <- getCommitData lConvOrSub (msgEpoch msg) commit -- check that the welcome message matches the action for_ (cbWelcome bundle) $ \welcome -> when @@ -306,22 +310,20 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do qusr senderClient conn - lconv - mlsMeta - cm + lConvOrSub (msgEpoch msg) action (msgSender msg) commit - storeGroupInfoBundle lconv (cbGroupInfoBundle bundle) + storeGroupInfoBundle (idForConvOrSub . tUnqualified $ lConvOrSub) (cbGroupInfoBundle bundle) pure updates ApplicationMessage _ -> throwS @'MLSUnsupportedMessage ProposalMessage _ -> throwS @'MLSUnsupportedMessage - propagateMessage qusr (qualifyAs lcnv conv) cm conn (rmRaw (cbCommitMsg bundle)) + propagateMessage qusr lConvOrSub conn (rmRaw (cbCommitMsg bundle)) for_ (cbWelcome bundle) $ - postMLSWelcome lcnv conn + postMLSWelcome lConvOrSub conn pure events @@ -343,19 +345,20 @@ postMLSCommitBundleToRemoteConv :: Qualified UserId -> Maybe ConnId -> CommitBundle -> - Remote ConvId -> + Remote ConvOrSubConvId -> Sem r [LocalConversationUpdate] -postMLSCommitBundleToRemoteConv loc qusr con bundle rcnv = do +postMLSCommitBundleToRemoteConv loc qusr con bundle rConvOrSubId = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr -- only members may send commit bundles to a remote conversation - flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) rcnv + + flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) (convOfConvOrSub <$> rConvOrSubId) resp <- - runFederated rcnv $ + runFederated rConvOrSubId $ fedClient @'Galley @"send-mls-commit-bundle" $ MLSMessageSendRequest - { mmsrConvOrSubId = Conv $ tUnqualified rcnv, + { mmsrConvOrSubId = tUnqualified rConvOrSubId, mmsrSender = tUnqualified lusr, mmsrRawMessage = Base64ByteString (serializeCommitBundle bundle) } @@ -366,7 +369,7 @@ postMLSCommitBundleToRemoteConv loc qusr con bundle rcnv = do MLSMessageResponseUpdates updates -> pure updates for updates $ \update -> do - e <- notifyRemoteConversationAction loc (qualifyAs rcnv update) con + e <- notifyRemoteConversationAction loc (qualifyAs rConvOrSubId update) con pure (LocalConversationUpdate e update) postMLSMessage :: @@ -390,6 +393,7 @@ postMLSMessage :: Input (Local ()), ProposalStore, Resource, + SubConversationStore, TinyLog ] r @@ -397,18 +401,18 @@ postMLSMessage :: Local x -> Qualified UserId -> Maybe ClientId -> - Qualified ConvId -> + Qualified ConvOrSubConvId -> Maybe ConnId -> RawMLS SomeMessage -> Sem r [LocalConversationUpdate] -postMLSMessage loc qusr mc qcnv con smsg = case rmValue smsg of +postMLSMessage loc qusr mc qconvOrSub con smsg = case rmValue smsg of SomeMessage tag msg -> do mSender <- fmap ciClient <$> getSenderIdentity qusr mc tag msg foldQualified loc (postMLSMessageToLocalConv qusr mSender con smsg) (postMLSMessageToRemoteConv loc qusr mSender con smsg) - qcnv + qconvOrSub -- Check that the MLS client who created the message belongs to the user who -- is the sender of the REST request, identified by HTTP header. @@ -474,8 +478,12 @@ postMLSMessageToLocalConv :: ErrorS 'MLSSelfRemovalNotAllowed, ErrorS 'MLSStaleMessage, ErrorS 'MLSUnsupportedMessage, + ErrorS 'MissingLegalholdConsent, + ErrorS 'ConvNotFound, + MemberStore, ProposalStore, Resource, + SubConversationStore, TinyLog ] r @@ -484,39 +492,37 @@ postMLSMessageToLocalConv :: Maybe ClientId -> Maybe ConnId -> RawMLS SomeMessage -> - Local ConvId -> + Local ConvOrSubConvId -> Sem r [LocalConversationUpdate] -postMLSMessageToLocalConv qusr senderClient con smsg lcnv = case rmValue smsg of +postMLSMessageToLocalConv qusr senderClient con smsg convOrSubId = case rmValue smsg of SomeMessage tag msg -> do - conv <- getLocalConvForUser qusr lcnv - mlsMeta <- Data.mlsMetadata conv & noteS @'ConvNotFound - - -- construct client map - cm <- lookupMLSClients (cnvmlsGroupId mlsMeta) - let lconv = qualifyAs lcnv conv + lConvOrSub <- fetchConvOrSub qusr convOrSubId -- validate message events <- case tag of SMLSPlainText -> case msgPayload msg of CommitMessage c -> - processCommit qusr senderClient con lconv mlsMeta cm (msgEpoch msg) (msgSender msg) c + processCommit qusr senderClient con lConvOrSub (msgEpoch msg) (msgSender msg) c ApplicationMessage _ -> throwS @'MLSUnsupportedMessage ProposalMessage prop -> - processProposal qusr conv mlsMeta msg prop $> mempty + processProposal qusr lConvOrSub msg prop $> mempty SMLSCipherText -> case toMLSEnum' (msgContentType (msgPayload msg)) of Right CommitMessageTag -> throwS @'MLSUnsupportedMessage Right ProposalMessageTag -> throwS @'MLSUnsupportedMessage Right ApplicationMessageTag -> pure mempty Left _ -> throwS @'MLSUnsupportedMessage - -- forward message - propagateMessage qusr lconv cm con (rmRaw smsg) + propagateMessage qusr lConvOrSub con (rmRaw smsg) pure events postMLSMessageToRemoteConv :: ( Members MLSMessageStaticErrors r, - Members '[Error FederationError, TinyLog] r, + Members + '[ Error FederationError, + TinyLog + ] + r, HasProposalEffects r ) => Local x -> @@ -524,19 +530,19 @@ postMLSMessageToRemoteConv :: Maybe ClientId -> Maybe ConnId -> RawMLS SomeMessage -> - Remote ConvId -> + Remote ConvOrSubConvId -> Sem r [LocalConversationUpdate] -postMLSMessageToRemoteConv loc qusr _senderClient con smsg rcnv = do +postMLSMessageToRemoteConv loc qusr _senderClient con smsg rConvOrSubId = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr -- only members may send messages to the remote conversation - flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) rcnv + flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) (convOfConvOrSub <$> rConvOrSubId) resp <- - runFederated rcnv $ + runFederated rConvOrSubId $ fedClient @'Galley @"send-mls-message" $ MLSMessageSendRequest - { mmsrConvOrSubId = Conv $ tUnqualified rcnv, + { mmsrConvOrSubId = tUnqualified rConvOrSubId, mmsrSender = tUnqualified lusr, mmsrRawMessage = Base64ByteString (rmRaw smsg) } @@ -547,7 +553,7 @@ postMLSMessageToRemoteConv loc qusr _senderClient con smsg rcnv = do MLSMessageResponseUpdates updates -> pure updates for updates $ \update -> do - e <- notifyRemoteConversationAction loc (qualifyAs rcnv update) con + e <- notifyRemoteConversationAction loc (qualifyAs rConvOrSubId update) con pure (LocalConversationUpdate e update) type HasProposalEffects r = @@ -613,19 +619,20 @@ getCommitData :: Member (Input UTCTime) r, Member TinyLog r ) => - Local Data.Conversation -> - ConversationMLSData -> + Local ConvOrSubConv -> Epoch -> Commit -> Sem r ProposalAction -getCommitData lconv mlsMeta epoch commit = do - let curEpoch = cnvmlsEpoch mlsMeta +getCommitData lConvOrSub epoch commit = do + let convOrSub = tUnqualified lConvOrSub + mlsMeta = mlsMetaConvOrSub convOrSub + curEpoch = cnvmlsEpoch mlsMeta groupId = cnvmlsGroupId mlsMeta suite = cnvmlsCipherSuite mlsMeta -- check epoch number when (epoch /= curEpoch) $ throwS @'MLSStaleMessage - foldMap (applyProposalRef (tUnqualified lconv) mlsMeta groupId epoch suite) (cProposals commit) + foldMap (applyProposalRef (idForConvOrSub convOrSub) mlsMeta groupId epoch suite) (cProposals commit) processCommit :: ( HasProposalEffects r, @@ -642,21 +649,20 @@ processCommit :: Member (Input (Local ())) r, Member ProposalStore r, Member BrigAccess r, - Member Resource r + Member Resource r, + Member SubConversationStore r ) => Qualified UserId -> Maybe ClientId -> Maybe ConnId -> - Local Data.Conversation -> - ConversationMLSData -> - ClientMap -> + Local ConvOrSubConv -> Epoch -> Sender 'MLSPlainText -> Commit -> Sem r [LocalConversationUpdate] -processCommit qusr senderClient con lconv mlsMeta cm epoch sender commit = do - action <- getCommitData lconv mlsMeta epoch commit - processCommitWithAction qusr senderClient con lconv mlsMeta cm epoch action sender commit +processCommit qusr senderClient con lConvOrSub epoch sender commit = do + action <- getCommitData lConvOrSub epoch commit + processCommitWithAction qusr senderClient con lConvOrSub epoch action sender commit processExternalCommit :: forall r. @@ -669,6 +675,7 @@ processExternalCommit :: ErrorS 'MLSKeyPackageRefNotFound, ErrorS 'MLSStaleMessage, ErrorS 'MLSMissingSenderClient, + Error InternalError, ExternalAccess, FederatorAccess, GundeckAccess, @@ -677,19 +684,19 @@ processExternalCommit :: MemberStore, ProposalStore, Resource, + SubConversationStore, TinyLog ] r => Qualified UserId -> Maybe ClientId -> - Local Data.Conversation -> - ConversationMLSData -> - ClientMap -> + Local ConvOrSubConv -> Epoch -> ProposalAction -> Maybe UpdatePath -> Sem r () -processExternalCommit qusr mSenderClient lconv mlsMeta cm epoch action updatePath = withCommitLock (cnvmlsGroupId mlsMeta) epoch $ do +processExternalCommit qusr mSenderClient lConvOrSub epoch action updatePath = withCommitLock (cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub) epoch $ do + let convOrSub = tUnqualified lConvOrSub newKeyPackage <- upLeaf <$> note @@ -711,7 +718,7 @@ processExternalCommit qusr mSenderClient lconv mlsMeta cm epoch action updatePat nkpresClientIdentity <$$> validateAndAddKeyPackageRef NewKeyPackage - { nkpConversation = Data.convId <$> tUntagged lconv, + { nkpConversation = tUntagged (convOfConvOrSub . idForConvOrSub <$> lConvOrSub), nkpKeyPackage = KeyPackageData (rmRaw newKeyPackage) } cid <- either (\errMsg -> throw (mlsProtocolError ("Tried to add invalid KeyPackage: " <> errMsg))) pure eithCid @@ -738,16 +745,18 @@ processExternalCommit qusr mSenderClient lconv mlsMeta cm epoch action updatePat $ "The external commit attempts to remove a client from a user other than themselves" pure (Just r) - updateKeyPackageMapping lconv (cnvmlsGroupId mlsMeta) qusr (ciClient cid) remRef newRef + updateKeyPackageMapping lConvOrSub qusr (ciClient cid) remRef newRef -- increment epoch number - setConversationEpoch (Data.convId (tUnqualified lconv)) (succ epoch) - -- fetch local conversation with new epoch - lc <- qualifyAs lconv <$> getLocalConvForUser qusr (convId <$> lconv) + setConvOrSubEpoch (idForConvOrSub convOrSub) (succ epoch) + -- fetch conversation or sub with new epoch + lConvOrSub' <- fetchConvOrSub qusr (idForConvOrSub <$> lConvOrSub) + let convOrSub' = tUnqualified lConvOrSub + -- fetch backend remove proposals of the previous epoch - kpRefs <- getPendingBackendRemoveProposals (cnvmlsGroupId mlsMeta) epoch + kpRefs <- getPendingBackendRemoveProposals (cnvmlsGroupId . mlsMetaConvOrSub $ convOrSub') epoch -- requeue backend remove proposals for the current epoch - removeClientsWithClientMap lc kpRefs cm qusr + removeClientsWithClientMap lConvOrSub' kpRefs qusr where derefUser :: ClientMap -> Qualified UserId -> Sem r (ClientIdentity, KeyPackageRef) derefUser (Map.toList -> l) user = case l of @@ -784,23 +793,22 @@ processCommitWithAction :: Member (Input (Local ())) r, Member ProposalStore r, Member BrigAccess r, - Member Resource r + Member Resource r, + Member SubConversationStore r ) => Qualified UserId -> Maybe ClientId -> Maybe ConnId -> - Local Data.Conversation -> - ConversationMLSData -> - ClientMap -> + Local ConvOrSubConv -> Epoch -> ProposalAction -> Sender 'MLSPlainText -> Commit -> Sem r [LocalConversationUpdate] -processCommitWithAction qusr senderClient con lconv mlsMeta cm epoch action sender commit = +processCommitWithAction qusr senderClient con lConvOrSub epoch action sender commit = case sender of - MemberSender ref -> processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action ref commit - NewMemberSender -> processExternalCommit qusr senderClient lconv mlsMeta cm epoch action (cPath commit) $> [] + MemberSender ref -> processInternalCommit qusr senderClient con lConvOrSub epoch action ref commit + NewMemberSender -> processExternalCommit qusr senderClient lConvOrSub epoch action (cPath commit) $> [] _ -> throw (mlsProtocolError "Unexpected sender") processInternalCommit :: @@ -824,24 +832,29 @@ processInternalCommit :: Qualified UserId -> Maybe ClientId -> Maybe ConnId -> - Local Data.Conversation -> - ConversationMLSData -> - ClientMap -> + Local ConvOrSubConv -> Epoch -> ProposalAction -> KeyPackageRef -> Commit -> Sem r [LocalConversationUpdate] -processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action senderRef commit = do - self <- noteS @'ConvNotFound $ getConvMember lconv (tUnqualified lconv) qusr - - withCommitLock (cnvmlsGroupId mlsMeta) epoch $ do +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 + + withCommitLock (cnvmlsGroupId . mlsMetaConvOrSub $ convOrSub) epoch $ do postponedKeyPackageRefUpdate <- if epoch == Epoch 0 then do - let cType = cnvmType . convMetadata . tUnqualified $ lconv - case (self, cType, cmAssocs cm) of - (Left _, SelfConv, []) -> do + let cType = cnvmType . convMetadata . mcConv . convOfConvOrSub $ convOrSub + case (self, cType, cmAssocs . membersConvOrSub $ convOrSub, convOrSub) of + (Left _, SelfConv, [], Conv _) -> do creatorClient <- noteS @'MLSMissingSenderClient senderClient creatorRef <- maybe @@ -855,13 +868,12 @@ processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action sender (cnvmlsGroupId mlsMeta) qusr (Set.singleton (creatorClient, creatorRef)) - (Left _, SelfConv, _) -> - throw . InternalErrorWithDescription $ - "Unexpected creator client set in a self-conversation" - -- this is a newly created conversation, and it should contain exactly one - -- client (the creator) - (Left lm, _, [(qu, (creatorClient, _))]) - | qu == tUntagged (qualifyAs lconv (lmId lm)) -> do + (Left _, 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 -- use update path as sender reference and if not existing fall back to sender senderRef' <- maybe @@ -872,11 +884,17 @@ processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action sender ) $ cPath commit -- register the creator client - updateKeyPackageMapping lconv (cnvmlsGroupId mlsMeta) qusr creatorClient Nothing senderRef' + updateKeyPackageMapping + lConvOrSub + qusr + creatorClient + Nothing + senderRef' -- remote clients cannot send the first commit - (Right _, _, _) -> throwS @'MLSStaleMessage + (Right _, _, _, _) -> throwS @'MLSStaleMessage + (_, _, _, SubConv _ _) -> pure () -- uninitialised conversations should contain exactly one client - (_, _, _) -> + (_, _, _, Conv _) -> throw (InternalErrorWithDescription "Unexpected creator client set") pure $ pure () -- no key package ref update necessary else case upLeaf <$> cPath commit of @@ -884,7 +902,15 @@ processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action sender updatedRef <- kpRef' updatedKeyPackage & note (mlsProtocolError "Could not compute key package ref") -- postpone key package ref update until other checks/processing passed case senderClient of - Just cli -> pure (updateKeyPackageMapping lconv (cnvmlsGroupId mlsMeta) qusr cli (Just senderRef) updatedRef) + Just cli -> + pure + ( updateKeyPackageMapping + lConvOrSub + qusr + cli + (Just senderRef) + updatedRef + ) Nothing -> pure (pure ()) Nothing -> pure (pure ()) -- ignore commits without update path @@ -895,37 +921,37 @@ processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action sender throwS @'MLSCommitMissingReferences -- process and execute proposals - updates <- executeProposalAction qusr con lconv mlsMeta cm action + updates <- executeProposalAction lConvOrSub qusr con convOrSub action -- update key package ref if necessary postponedKeyPackageRefUpdate -- increment epoch number - setConversationEpoch (Data.convId (tUnqualified lconv)) (succ epoch) + setConvOrSubEpoch (idForConvOrSub convOrSub) (succ epoch) pure updates -- | Note: Use this only for KeyPackage that are already validated updateKeyPackageMapping :: Members '[BrigAccess, MemberStore] r => - Local Data.Conversation -> - GroupId -> + Local ConvOrSubConv -> Qualified UserId -> ClientId -> Maybe KeyPackageRef -> KeyPackageRef -> Sem r () -updateKeyPackageMapping lconv groupId qusr cid mOld new = do - let lcnv = fmap Data.convId lconv +updateKeyPackageMapping lConvOrSub qusr cid mOld new = do + let qconv = tUntagged (convOfConvOrSub . idForConvOrSub <$> lConvOrSub) -- update actual mapping in brig case mOld of Nothing -> - addKeyPackageRef new qusr cid (tUntagged lcnv) + addKeyPackageRef new qusr cid qconv Just old -> updateKeyPackageRef KeyPackageUpdate { kpupPrevious = old, kpupNext = new } + let groupId = cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub -- remove old (client, key package) pair removeMLSClients groupId qusr (Set.singleton cid) @@ -942,50 +968,50 @@ applyProposalRef :: ] r ) => - Data.Conversation -> + ConvOrSubConvId -> ConversationMLSData -> GroupId -> Epoch -> CipherSuiteTag -> ProposalOrRef -> Sem r ProposalAction -applyProposalRef conv mlsMeta groupId epoch _suite (Ref ref) = do +applyProposalRef convOrSubConvId mlsMeta groupId epoch _suite (Ref ref) = do p <- getProposal groupId epoch ref >>= noteS @'MLSProposalNotFound checkEpoch epoch mlsMeta checkGroup groupId mlsMeta - applyProposal (convId conv) groupId (rmValue p) -applyProposalRef conv _mlsMeta groupId _epoch suite (Inline p) = do + applyProposal convOrSubConvId groupId (rmValue p) +applyProposalRef convOrSubConvId _mlsMeta groupId _epoch suite (Inline p) = do checkProposalCipherSuite suite p - applyProposal (convId conv) groupId p + applyProposal convOrSubConvId groupId p applyProposal :: forall r. HasProposalEffects r => - ConvId -> + ConvOrSubConvId -> GroupId -> Proposal -> Sem r ProposalAction -applyProposal convId groupId (AddProposal kp) = do +applyProposal convOrSubConvId groupId (AddProposal kp) = do ref <- kpRef' kp & note (mlsProtocolError "Could not compute ref of a key package in an Add proposal") mbClientIdentity <- getClientByKeyPackageRef ref clientIdentity <- case mbClientIdentity of Nothing -> do -- external add proposal for a new key package unknown to the backend - lconvId <- qualifyLocal convId - addKeyPackageMapping lconvId ref (KeyPackageData (rmRaw kp)) + lConvOrSubConvId <- qualifyLocal convOrSubConvId + addKeyPackageMapping lConvOrSubConvId ref (KeyPackageData (rmRaw kp)) Just ci -> -- ad-hoc add proposal in commit, the key package has been claimed before pure ci pure (paAddClient . (<$$>) (,ref) . cidQualifiedClient $ clientIdentity) where - addKeyPackageMapping :: Local ConvId -> KeyPackageRef -> KeyPackageData -> Sem r ClientIdentity - addKeyPackageMapping lconv ref kpdata = do + addKeyPackageMapping :: Local ConvOrSubConvId -> KeyPackageRef -> KeyPackageData -> Sem r ClientIdentity + addKeyPackageMapping lConvOrSubConvId ref kpdata = do -- validate and update mapping in brig eithCid <- nkpresClientIdentity <$$> validateAndAddKeyPackageRef NewKeyPackage - { nkpConversation = tUntagged lconv, + { nkpConversation = tUntagged (convOfConvOrSub <$> lConvOrSubConvId), nkpKeyPackage = kpdata } cid <- either (\errMsg -> throw (mlsProtocolError ("Tried to add invalid KeyPackage: " <> errMsg))) pure eithCid @@ -994,14 +1020,14 @@ applyProposal convId groupId (AddProposal kp) = do -- update mapping in galley addMLSClients groupId qusr (Set.singleton (ciClient cid, ref)) pure cid -applyProposal _conv _groupId (RemoveProposal ref) = do +applyProposal _convOrSubConvId _groupId (RemoveProposal ref) = do qclient <- cidQualifiedClient <$> derefKeyPackage ref pure (paRemoveClient ((,ref) <$$> qclient)) -applyProposal _conv _groupId (ExternalInitProposal _) = +applyProposal _convOrSubConvId _groupId (ExternalInitProposal _) = -- only record the fact there was an external init proposal, but do not -- process it in any way. pure paExternalInitPresent -applyProposal _conv _groupId _ = pure mempty +applyProposal _convOrSubConvId _groupId _ = pure mempty checkProposalCipherSuite :: Members @@ -1036,15 +1062,16 @@ processProposal :: ] r => Qualified UserId -> - Data.Conversation -> - ConversationMLSData -> + Local ConvOrSubConv -> Message 'MLSPlainText -> RawMLS Proposal -> Sem r () -processProposal qusr conv mlsMeta msg prop = do +processProposal qusr lConvOrSub msg prop = do + let mlsMeta = mlsMetaConvOrSub (tUnqualified lConvOrSub) checkEpoch (msgEpoch msg) mlsMeta checkGroup (msgGroupId msg) mlsMeta let suiteTag = cnvmlsCipherSuite mlsMeta + let cid = convId . mcConv . convOfConvOrSub . tUnqualified $ lConvOrSub -- validate the proposal -- @@ -1054,11 +1081,11 @@ processProposal qusr conv mlsMeta msg prop = do foldQualified loc ( fmap isJust - . getLocalMember (convId conv) + . getLocalMember cid . tUnqualified ) ( fmap isJust - . getRemoteMember (convId conv) + . getRemoteMember cid ) qusr unless isMember' $ throwS @'ConvNotFound @@ -1131,7 +1158,7 @@ checkExternalProposalUser qusr prop = do qusr executeProposalAction :: - forall r. + forall r x. ( Member BrigAccess r, Member ConversationStore r, Member (Error InternalError) r, @@ -1155,15 +1182,18 @@ executeProposalAction :: Member TeamStore r, Member TinyLog r ) => + Local x -> Qualified UserId -> Maybe ConnId -> - Local Data.Conversation -> - ConversationMLSData -> - ClientMap -> + ConvOrSubConv -> ProposalAction -> Sem r [LocalConversationUpdate] -executeProposalAction qusr con lconv mlsMeta cm action = do - let ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta) +executeProposalAction _loc _qusr _con (SubConv _ _) _action = pure [] +executeProposalAction loc qusr con (Conv mlsConv) action = do + let lconv = qualifyAs loc . mcConv $ mlsConv + mlsMeta = mcMLSData mlsConv + cm = mcMembers mlsConv + ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta) newUserClients = Map.assocs (paAdd action) -- Note [client removal] @@ -1218,17 +1248,17 @@ executeProposalAction qusr con lconv mlsMeta cm action = do -- FUTUREWORK: turn this error into a proper response throwS @'MLSClientMismatch - membersToRemove <- catMaybes <$> for removedUsers (uncurry checkRemoval) + membersToRemove <- catMaybes <$> for removedUsers (uncurry (checkRemoval cm)) -- add users to the conversation and send events - addEvents <- foldMap addMembers . nonEmpty . map fst $ newUserClients + addEvents <- foldMap (addMembers lconv) . nonEmpty . map fst $ newUserClients -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do addMLSClients (cnvmlsGroupId mlsMeta) qtarget newClients -- remove users from the conversation and send events - removeEvents <- foldMap removeMembers (nonEmpty membersToRemove) + removeEvents <- foldMap (removeMembers lconv) (nonEmpty membersToRemove) -- Remove clients from the conversation state. This includes client removals -- of all types (see Note [client removal]). @@ -1238,10 +1268,11 @@ executeProposalAction qusr con lconv mlsMeta cm action = do pure (addEvents <> removeEvents) where checkRemoval :: + ClientMap -> Qualified UserId -> Set ClientId -> Sem r (Maybe (Qualified UserId)) - checkRemoval qtarget clients = do + checkRemoval cm qtarget clients = do let clientsInConv = Set.map fst (Map.findWithDefault mempty qtarget cm) when (clients /= clientsInConv) $ do -- FUTUREWORK: turn this error into a proper response @@ -1250,20 +1281,20 @@ executeProposalAction qusr con lconv mlsMeta cm action = do throwS @'MLSSelfRemovalNotAllowed pure (Just qtarget) - existingLocalMembers :: Set (Qualified UserId) - existingLocalMembers = + existingLocalMembers :: Local Data.Conversation -> Set (Qualified UserId) + existingLocalMembers lconv = (Set.fromList . map (fmap lmId . tUntagged)) (traverse convLocalMembers lconv) - existingRemoteMembers :: Set (Qualified UserId) - existingRemoteMembers = + existingRemoteMembers :: Local Data.Conversation -> Set (Qualified UserId) + existingRemoteMembers lconv = Set.fromList . map (tUntagged . rmId) . convRemoteMembers . tUnqualified $ lconv - existingMembers :: Set (Qualified UserId) - existingMembers = existingLocalMembers <> existingRemoteMembers + existingMembers :: Local Data.Conversation -> Set (Qualified UserId) + existingMembers lconv = existingLocalMembers lconv <> existingRemoteMembers lconv - addMembers :: NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] - addMembers = + addMembers :: Local Data.Conversation -> NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] + addMembers lconv = -- FUTUREWORK: update key package ref mapping to reflect conversation membership foldMap ( handleNoChanges @@ -1273,11 +1304,11 @@ executeProposalAction qusr con lconv mlsMeta cm action = do . flip ConversationJoin roleNameWireMember ) . nonEmpty - . filter (flip Set.notMember existingMembers) + . filter (flip Set.notMember (existingMembers lconv)) . toList - removeMembers :: NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] - removeMembers = + removeMembers :: Local Data.Conversation -> NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] + removeMembers lconv = foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors @@ -1285,7 +1316,7 @@ executeProposalAction qusr con lconv mlsMeta cm action = do . updateLocalConversationUnchecked @'ConversationRemoveMembersTag lconv qusr con ) . nonEmpty - . filter (flip Set.member existingMembers) + . filter (flip Set.member (existingMembers lconv)) . toList handleNoChanges :: Monoid a => Sem (Error NoChanges ': r) a -> Sem r a @@ -1402,11 +1433,55 @@ withCommitLock gid epoch action = ttl = fromIntegral (600 :: Int) -- 10 minutes storeGroupInfoBundle :: - Member ConversationStore r => - Local Data.Conversation -> + Members + '[ ConversationStore, + SubConversationStore + ] + r => + ConvOrSubConvId -> GroupInfoBundle -> Sem r () -storeGroupInfoBundle lconv = - setPublicGroupState (Data.convId (tUnqualified lconv)) - . toOpaquePublicGroupState - . gipGroupState +storeGroupInfoBundle convOrSub bundle = case convOrSub of + Conv cid -> do + setPublicGroupState cid + . toOpaquePublicGroupState + . gipGroupState + $ bundle + SubConv _cid _subconvid -> do + -- FUTUREWORK: Write to subconversation + pure () + +fetchConvOrSub :: + forall r. + Members + '[ ConversationStore, + Error InternalError, + ErrorS 'ConvNotFound, + MemberStore, + SubConversationStore + ] + r => + Qualified UserId -> + Local ConvOrSubConvId -> + Sem r (Local ConvOrSubConv) +fetchConvOrSub qusr convOrSubId = for convOrSubId $ \case + Conv convId -> Conv <$> getMLSConv qusr (qualifyAs convOrSubId convId) + SubConv convId sconvId -> do + let lconv = qualifyAs convOrSubId convId + c <- getMLSConv qusr lconv + subconv <- getSubConversation lconv 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 () diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index ab6e387661..c7cbb2a3ef 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -44,6 +44,7 @@ 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. @@ -55,52 +56,59 @@ propagateMessage :: Member TinyLog r ) => Qualified UserId -> - Local Data.Conversation -> - ClientMap -> + Local ConvOrSubConv -> Maybe ConnId -> ByteString -> Sem r () -propagateMessage qusr lconv cm con raw = do - -- 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) +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) - -- 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, - rmmMessage = Base64ByteString raw - } + -- 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 + } where - localMemberMLSClients :: Local x -> LocalMember -> [(UserId, ClientId)] - localMemberMLSClients loc lm = + localMemberMLSClients :: Local x -> ClientMap -> LocalMember -> [(UserId, ClientId)] + localMemberMLSClients loc cm lm = let localUserQId = tUntagged (qualifyAs loc localUserId) localUserId = lmId lm in map (\(c, _) -> (localUserId, c)) (toList (Map.findWithDefault mempty localUserQId cm)) - remoteMemberMLSClients :: RemoteMember -> [(UserId, ClientId)] - remoteMemberMLSClients rm = + remoteMemberMLSClients :: ClientMap -> RemoteMember -> [(UserId, ClientId)] + remoteMemberMLSClients cm rm = let remoteUserQId = tUntagged (rmId rm) remoteUserId = qUnqualified remoteUserQId in map diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/services/galley/src/Galley/API/MLS/Removal.hs index f16edf2bd2..6f96c071b4 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/services/galley/src/Galley/API/MLS/Removal.hs @@ -18,7 +18,6 @@ module Galley.API.MLS.Removal ( removeClientsWithClientMap, removeClient, - removeUserWithClientMap, removeUser, ) where @@ -48,6 +47,7 @@ import Wire.API.MLS.KeyPackage import Wire.API.MLS.Message import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation +import Wire.API.MLS.SubConversation -- | Send remove proposals for a set of clients to clients in the ClientMap. removeClientsWithClientMap :: @@ -63,31 +63,28 @@ removeClientsWithClientMap :: r, Traversable t ) => - Local Data.Conversation -> + Local ConvOrSubConv -> t KeyPackageRef -> - ClientMap -> Qualified UserId -> Sem r () -removeClientsWithClientMap lc cs cm qusr = do - case Data.convProtocol (tUnqualified lc) of - ProtocolProteus -> pure () - ProtocolMLS meta -> do - mKeyPair <- getMLSRemovalKey - case mKeyPair of - Nothing -> do - warn $ Log.msg ("No backend removal key is configured (See 'mlsPrivateKeyPaths' in galley's config). Not able to remove client from MLS conversation." :: Text) - Just (secKey, pubKey) -> do - for_ cs $ \kpref -> do - let proposal = mkRemoveProposal kpref - msg = mkSignedMessage secKey pubKey (cnvmlsGroupId meta) (cnvmlsEpoch meta) (ProposalMessage proposal) - msgEncoded = encodeMLS' msg - storeProposal - (cnvmlsGroupId meta) - (cnvmlsEpoch meta) - (proposalRef (cnvmlsCipherSuite meta) proposal) - ProposalOriginBackend - proposal - propagateMessage qusr lc cm Nothing msgEncoded +removeClientsWithClientMap lConvOrSubConv cs qusr = do + let meta = mlsMetaConvOrSub (tUnqualified lConvOrSubConv) + mKeyPair <- getMLSRemovalKey + case mKeyPair of + Nothing -> do + warn $ Log.msg ("No backend removal key is configured (See 'mlsPrivateKeyPaths' in galley's config). Not able to remove client from MLS conversation." :: Text) + Just (secKey, pubKey) -> do + for_ cs $ \kpref -> do + let proposal = mkRemoveProposal kpref + msg = mkSignedMessage secKey pubKey (cnvmlsGroupId meta) (cnvmlsEpoch meta) (ProposalMessage proposal) + msgEncoded = encodeMLS' msg + storeProposal + (cnvmlsGroupId meta) + (cnvmlsEpoch meta) + (proposalRef (cnvmlsCipherSuite meta) proposal) + ProposalOriginBackend + proposal + propagateMessage qusr lConvOrSubConv Nothing msgEncoded -- | Send remove proposals for a single client of a user to the local conversation. removeClient :: @@ -109,33 +106,12 @@ removeClient :: ClientId -> Sem r () removeClient lc qusr cid = do - for_ (cnvmlsGroupId <$> Data.mlsMetadata (tUnqualified lc)) $ \groupId -> do - cm <- lookupMLSClients groupId + for_ (Data.mlsMetadata (tUnqualified lc)) $ \mlsMeta -> 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 lc cidAndKP cm qusr - --- | Send remove proposals for all clients of the user to clients in the ClientMap. --- --- All clients of the user have to be contained in the ClientMap. -removeUserWithClientMap :: - ( Members - '[ Input UTCTime, - TinyLog, - ExternalAccess, - FederatorAccess, - GundeckAccess, - Error InternalError, - ProposalStore, - Input Env - ] - r - ) => - Local Data.Conversation -> - ClientMap -> - Qualified UserId -> - Sem r () -removeUserWithClientMap lc cm qusr = - removeClientsWithClientMap lc (Set.toList . Set.map snd $ Map.findWithDefault mempty qusr cm) cm qusr + removeClientsWithClientMap (qualifyAs lc (Conv mlsConv)) cidAndKP qusr -- | Send remove proposals for all clients of the user to the local conversation. removeUser :: @@ -156,6 +132,8 @@ removeUser :: Qualified UserId -> Sem r () removeUser lc qusr = do - for_ (Data.mlsMetadata (tUnqualified lc)) $ \meta -> do - cm <- lookupMLSClients (cnvmlsGroupId meta) - removeUserWithClientMap lc cm qusr + for_ (Data.mlsMetadata (tUnqualified lc)) $ \mlsMeta -> 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 diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs new file mode 100644 index 0000000000..7446376511 --- /dev/null +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -0,0 +1,111 @@ +-- 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.SubConversation where + +import Data.Id +import Data.Qualified +import Galley.API.Error +import Galley.API.MLS.Types +import Galley.API.Util (getConversationAndCheckMembership) +import qualified Galley.Data.Conversation as Data +import Galley.Data.Conversation.Types +import Galley.Effects.ConversationStore (ConversationStore) +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 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.MLS.SubConversation + +getSubConversation :: + Members + '[ SubConversationStore, + ConversationStore, + ErrorS 'ConvNotFound, + ErrorS 'ConvAccessDenied, + ErrorS 'MLSSubConvUnsupportedConvType, + Error InternalError, + Error Wai.Error, + P.TinyLog + ] + r => + Local UserId -> + Qualified ConvId -> + SubConvId -> + Sem r PublicSubConversation +getSubConversation lusr qconv sconv = do + foldQualified + lusr + (\lcnv -> getLocalSubConversation lusr lcnv sconv) + (\_rcnv -> throw federationNotImplemented) + qconv + +getLocalSubConversation :: + Members + '[ SubConversationStore, + ConversationStore, + ErrorS 'ConvNotFound, + ErrorS 'ConvAccessDenied, + ErrorS 'MLSSubConvUnsupportedConvType, + Error InternalError, + P.TinyLog + ] + r => + Local UserId -> + Local ConvId -> + SubConvId -> + Sem r PublicSubConversation +getLocalSubConversation lusr lconv sconv = do + c <- getConversationAndCheckMembership (tUnqualified lusr) lconv + + unless (Data.convType c == RegularConv) $ + throwS @'MLSSubConvUnsupportedConvType + + msub <- Eff.getSubConversation lconv sconv + sub <- case msub of + Nothing -> do + mlsMeta <- noteS @'ConvNotFound (mlsMetadata c) + -- deriving this detemernistically to prevent race condition between + -- multiple threads creating the subconversation + let groupId = initialGroupId lconv sconv + epoch = Epoch 0 + suite = cnvmlsCipherSuite mlsMeta + createSubConversation (tUnqualified lconv) sconv suite epoch groupId Nothing + setGroupIdForSubConversation groupId (tUntagged lconv) sconv + let sub = + SubConversation + { scParentConvId = lconv, + scSubConvId = sconv, + scMLSData = + ConversationMLSData + { cnvmlsGroupId = groupId, + cnvmlsEpoch = epoch, + cnvmlsCipherSuite = suite + }, + scMembers = mkClientMap [] + } + pure sub + Just sub -> pure sub + pure (toPublicSubConv sub) diff --git a/services/galley/src/Galley/API/MLS/Types.hs b/services/galley/src/Galley/API/MLS/Types.hs index 935702c3a5..aeee9fe2bc 100644 --- a/services/galley/src/Galley/API/MLS/Types.hs +++ b/services/galley/src/Galley/API/MLS/Types.hs @@ -14,22 +14,22 @@ -- -- 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.MLS.Types - ( ClientMap, - mkClientMap, - cmAssocs, - ListGlobalSelfConvs (..), - ) -where +module Galley.API.MLS.Types where 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 Imports +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)) @@ -48,3 +48,48 @@ cmAssocs cm = Map.assocs cm >>= traverse toList -- response. data ListGlobalSelfConvs = ListGlobalSelf | DoNotListGlobalSelf deriving (Eq) + +data MLSConversation = MLSConversation + { mcConv :: Conversation, + mcMLSData :: ConversationMLSData, + mcMembers :: ClientMap + } + deriving (Show) + +data SubConversation = SubConversation + { scParentConvId :: Local ConvId, + scSubConvId :: SubConvId, + scMLSData :: ConversationMLSData, + scMembers :: ClientMap + } + deriving (Eq, Show) + +toPublicSubConv :: SubConversation -> PublicSubConversation +toPublicSubConv SubConversation {..} = + let members = fmap (\(quid, (cid, _kp)) -> mkClientIdentity quid cid) (cmAssocs scMembers) + in PublicSubConversation + { pscParentConvId = tUntagged scParentConvId, + pscSubConvId = scSubConvId, + pscGroupId = cnvmlsGroupId scMLSData, + pscEpoch = cnvmlsEpoch scMLSData, + pscCipherSuite = cnvmlsCipherSuite scMLSData, + pscMembers = members + } + +type ConvOrSubConv = ConvOrSubChoice MLSConversation SubConversation + +mlsMetaConvOrSub :: ConvOrSubConv -> ConversationMLSData +mlsMetaConvOrSub (Conv c) = mcMLSData c +mlsMetaConvOrSub (SubConv _ s) = scMLSData s + +membersConvOrSub :: ConvOrSubConv -> ClientMap +membersConvOrSub (Conv c) = mcMembers c +membersConvOrSub (SubConv _ s) = scMembers s + +convOfConvOrSub :: ConvOrSubChoice c s -> c +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) diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index f14ee73397..8d9437f8af 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -19,6 +19,7 @@ module Galley.API.Public.Conversation where import Galley.API.Create import Galley.API.MLS.GroupInfo +import Galley.API.MLS.SubConversation import Galley.API.MLS.Types import Galley.API.Query import Galley.API.Update @@ -47,6 +48,7 @@ conversationAPI = <@> mkNamedAPI @"create-self-conversation@v2" createProteusSelfConversation <@> mkNamedAPI @"create-self-conversation" createProteusSelfConversation <@> mkNamedAPI @"get-mls-self-conversation" getMLSSelfConversationWithError + <@> mkNamedAPI @"get-subconversation" getSubConversation <@> 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/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 1110ba9a14..ef544fe54c 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -22,7 +22,7 @@ module Galley.API.Util where import Control.Lens (set, view, (.~), (^.)) import Control.Monad.Extra (allM, anyM) import Data.Bifunctor -import Data.ByteString.Conversion +import Data.ByteString.Conversion (ToByteString, toByteString') import qualified Data.Code as Code import Data.Domain (Domain) import Data.Id as Id diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 4e18718f22..5f15bf3be8 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -70,6 +70,7 @@ import Galley.Cassandra.LegalHold import Galley.Cassandra.Proposal import Galley.Cassandra.SearchVisibility import Galley.Cassandra.Services +import Galley.Cassandra.SubConversation (interpretSubConversationStoreToCassandra) import Galley.Cassandra.Team import Galley.Cassandra.TeamFeatures import Galley.Cassandra.TeamNotifications @@ -257,6 +258,7 @@ evalGalley e = . interpretMemberStoreToCassandra . interpretLegalHoldStoreToCassandra lh . interpretCustomBackendStoreToCassandra + . interpretSubConversationStoreToCassandra . interpretConversationStoreToCassandra . interpretProposalStoreToCassandra . interpretCodeStoreToCassandra diff --git a/services/galley/src/Galley/Cassandra.hs b/services/galley/src/Galley/Cassandra.hs index ea4d501ef6..2056cfc2c2 100644 --- a/services/galley/src/Galley/Cassandra.hs +++ b/services/galley/src/Galley/Cassandra.hs @@ -20,4 +20,4 @@ module Galley.Cassandra (schemaVersion) where import Imports schemaVersion :: Int32 -schemaVersion = 77 +schemaVersion = 78 diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 1b26c2207f..a6ce01494d 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -27,6 +27,7 @@ import qualified Cassandra as Cql import Control.Error.Util import Control.Monad.Trans.Maybe import Data.ByteString.Conversion +import Data.Domain import Data.Id import qualified Data.Map as Map import Data.Misc @@ -56,6 +57,7 @@ import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite import Wire.API.MLS.Group import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.SubConversation createMLSSelfConversation :: Local UserId -> @@ -101,7 +103,7 @@ createMLSSelfConversation lusr = do Just gid, Just cs ) - addPrepQuery Cql.insertGroupId (gid, cnv, tDomain lusr) + addPrepQuery Cql.insertGroupIdForConversation (gid, cnv, tDomain lusr) (lmems, rmems) <- addMembers cnv (ncUsers nc) pure @@ -158,7 +160,7 @@ createConversation lcnv nc = do mcs ) for_ (cnvmTeam meta) $ \tid -> addPrepQuery Cql.insertTeamConv (tid, tUnqualified lcnv) - for_ mgid $ \gid -> addPrepQuery Cql.insertGroupId (gid, tUnqualified lcnv, tDomain lcnv) + for_ mgid $ \gid -> addPrepQuery Cql.insertGroupIdForConversation (gid, tUnqualified lcnv, tDomain lcnv) (lmems, rmems) <- addMembers (tUnqualified lcnv) (ncUsers nc) pure Conversation @@ -365,13 +367,19 @@ toConv cid ms remoteMems mconv = do } } -mapGroupId :: GroupId -> Qualified ConvId -> Client () -mapGroupId gId conv = - write Cql.insertGroupId (params LocalQuorum (gId, qUnqualified conv, qDomain conv)) +setGroupIdForConversation :: GroupId -> Qualified ConvId -> Client () +setGroupIdForConversation gId conv = + write Cql.insertGroupIdForConversation (params LocalQuorum (gId, qUnqualified conv, qDomain conv)) -lookupGroupId :: GroupId -> Client (Maybe (Qualified ConvId)) -lookupGroupId gId = - uncurry Qualified <$$> retry x1 (query1 Cql.lookupGroupId (params LocalQuorum (Identity gId))) +lookupConvByGroupId :: GroupId -> Client (Maybe (Qualified ConvOrSubConvId)) +lookupConvByGroupId gId = + toConvOrSubConv <$$> retry x1 (query1 Cql.lookupGroupId (params LocalQuorum (Identity gId))) + where + toConvOrSubConv :: (ConvId, Domain, Maybe SubConvId) -> Qualified ConvOrSubConvId + toConvOrSubConv (convId, domain, mbSubConvId) = + case mbSubConvId of + Nothing -> Qualified (Conv convId) domain + Just subConvId -> Qualified (SubConv convId subConvId) domain interpretConversationStoreToCassandra :: Members '[Embed IO, Input ClientState, TinyLog] r => @@ -382,7 +390,7 @@ interpretConversationStoreToCassandra = interpret $ \case CreateConversation loc nc -> embedClient $ createConversation loc nc CreateMLSSelfConversation lusr -> embedClient $ createMLSSelfConversation lusr GetConversation cid -> embedClient $ getConversation cid - GetConversationIdByGroupId gId -> embedClient $ lookupGroupId gId + LookupConvByGroupId gId -> embedClient $ lookupConvByGroupId gId GetConversations cids -> localConversations cids GetConversationMetadata cid -> embedClient $ conversationMeta cid GetPublicGroupState cid -> embedClient $ getPublicGroupState cid @@ -396,7 +404,7 @@ interpretConversationStoreToCassandra = interpret $ \case SetConversationMessageTimer cid value -> embedClient $ updateConvMessageTimer cid value SetConversationEpoch cid epoch -> embedClient $ updateConvEpoch cid epoch DeleteConversation cid -> embedClient $ deleteConversation cid - SetGroupId gId cid -> embedClient $ mapGroupId gId cid + SetGroupIdForConversation gId cid -> embedClient $ setGroupIdForConversation gId cid SetPublicGroupState cid gib -> embedClient $ setPublicGroupState cid gib AcquireCommitLock gId epoch ttl -> embedClient $ acquireCommitLock gId epoch ttl ReleaseCommitLock gId epoch -> embedClient $ releaseCommitLock gId epoch diff --git a/services/galley/src/Galley/Cassandra/Conversation/MLS.hs b/services/galley/src/Galley/Cassandra/Conversation/MLS.hs index 7fda951968..7ca5f89d35 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/MLS.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/MLS.hs @@ -15,11 +15,17 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Cassandra.Conversation.MLS where +module Galley.Cassandra.Conversation.MLS + ( acquireCommitLock, + releaseCommitLock, + lookupMLSClients, + ) +where import Cassandra import Cassandra.Settings (fromRow) import Data.Time +import Galley.API.MLS.Types import qualified Galley.Cassandra.Queries as Cql import Galley.Data.Types import Imports @@ -54,3 +60,10 @@ releaseCommitLock groupId epoch = checkTransSuccess :: [Row] -> Bool checkTransSuccess [] = False checkTransSuccess (row : _) = either (const False) (fromMaybe False) $ fromRow 0 row + +lookupMLSClients :: GroupId -> Client ClientMap +lookupMLSClients groupId = + mkClientMap + <$> retry + x5 + (query Cql.lookupMLSClients (params LocalQuorum (Identity groupId))) diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index 7f79df3042..147d76c6e7 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -32,7 +32,7 @@ import qualified Data.List.Extra as List import Data.Monoid import Data.Qualified import qualified Data.Set as Set -import Galley.API.MLS.Types +import Galley.Cassandra.Conversation.MLS (lookupMLSClients) import Galley.Cassandra.Instances () import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Services @@ -356,13 +356,6 @@ removeMLSClients groupId (Qualified usr domain) cs = retry x5 . batch $ do for_ cs $ \c -> addPrepQuery Cql.removeMLSClient (groupId, domain, usr, c) -lookupMLSClients :: GroupId -> Client ClientMap -lookupMLSClients groupId = - mkClientMap - <$> retry - x5 - (query Cql.lookupMLSClients (params LocalQuorum (Identity groupId))) - interpretMemberStoreToCassandra :: Members '[Embed IO, Input ClientState] r => Sem (MemberStore ': r) a -> diff --git a/services/galley/src/Galley/Cassandra/Instances.hs b/services/galley/src/Galley/Cassandra/Instances.hs index 90b648e8ff..8f9deba5ea 100644 --- a/services/galley/src/Galley/Cassandra/Instances.hs +++ b/services/galley/src/Galley/Cassandra/Instances.hs @@ -41,6 +41,7 @@ import Wire.API.MLS.CipherSuite import Wire.API.MLS.Proposal import Wire.API.MLS.PublicGroupState import Wire.API.MLS.Serialisation +import Wire.API.MLS.SubConversation import Wire.API.Team import qualified Wire.API.Team.Feature as Public import Wire.API.Team.SearchVisibility @@ -255,3 +256,9 @@ instance Cql CipherSuite where then Right . CipherSuite . fromIntegral $ i else Left "CipherSuite: an out of bounds value for Word16" fromCql _ = Left "CipherSuite: int expected" + +instance Cql SubConvId where + ctype = Tagged TextColumn + toCql = CqlText . unSubConvId + fromCql (CqlText txt) = Right (SubConvId txt) + fromCql _ = Left "SubConvId: Text expected" diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index 5cdac44f74..6b9379ad85 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -37,6 +37,7 @@ import Wire.API.Conversation.Role import Wire.API.MLS.CipherSuite import Wire.API.MLS.KeyPackage import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.SubConversation import Wire.API.Provider import Wire.API.Provider.Service import Wire.API.Team @@ -313,11 +314,31 @@ deleteUserConv = "delete from user where user = ? and conv = ?" -- MLS Conversations -------------------------------------------------------- -insertGroupId :: PrepQuery W (GroupId, ConvId, Domain) () -insertGroupId = "INSERT INTO group_id_conv_id (group_id, conv_id, domain) VALUES (?, ?, ?)" +insertGroupIdForConversation :: PrepQuery W (GroupId, ConvId, Domain) () +insertGroupIdForConversation = "INSERT INTO group_id_conv_id (group_id, conv_id, domain) VALUES (?, ?, ?)" -lookupGroupId :: PrepQuery R (Identity GroupId) (ConvId, Domain) -lookupGroupId = "SELECT conv_id, domain from group_id_conv_id where group_id = ?" +lookupGroupId :: PrepQuery R (Identity GroupId) (ConvId, Domain, Maybe SubConvId) +lookupGroupId = "SELECT conv_id, domain, subconv_id from group_id_conv_id where group_id = ?" + +-- MLS SubConversations ----------------------------------------------------- + +selectSubConversation :: PrepQuery R (ConvId, SubConvId) (CipherSuiteTag, Epoch, GroupId) +selectSubConversation = "SELECT cipher_suite, epoch, group_id FROM subconversation WHERE conv_id = ? and subconv_id = ?" + +insertSubConversation :: PrepQuery W (ConvId, SubConvId, CipherSuiteTag, Epoch, GroupId, Maybe OpaquePublicGroupState) () +insertSubConversation = "INSERT INTO subconversation (conv_id, subconv_id, cipher_suite, epoch, group_id, public_group_state) VALUES (?, ?, ?, ?, ?, ?)" + +updateSubConvPublicGroupState :: PrepQuery W (ConvId, SubConvId, Maybe OpaquePublicGroupState) () +updateSubConvPublicGroupState = "INSERT INTO subconversation (conv_id, subconv_id, public_group_state) VALUES (?, ?, ?)" + +selectSubConvPublicGroupState :: PrepQuery R (ConvId, SubConvId) (Identity (Maybe OpaquePublicGroupState)) +selectSubConvPublicGroupState = "SELECT public_group_state FROM subconversation WHERE conv_id = ? AND subconv_id = ?" + +insertGroupIdForSubConversation :: PrepQuery W (GroupId, ConvId, Domain, SubConvId) () +insertGroupIdForSubConversation = "INSERT INTO group_id_conv_id (group_id, conv_id, domain, subconv_id) VALUES (?, ?, ?, ?)" + +lookupGroupIdForSubConversation :: PrepQuery R (Identity GroupId) (ConvId, Domain, SubConvId) +lookupGroupIdForSubConversation = "SELECT conv_id, domain, subconv_id from group_id_conv_id where group_id = ?" -- Members ------------------------------------------------------------------ diff --git a/services/galley/src/Galley/Cassandra/SubConversation.hs b/services/galley/src/Galley/Cassandra/SubConversation.hs new file mode 100644 index 0000000000..0216f84ff7 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/SubConversation.hs @@ -0,0 +1,80 @@ +-- 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.Cassandra.SubConversation where + +import Cassandra +import Data.Id +import Data.Qualified +import Galley.API.MLS.Types (SubConversation (..)) +import Galley.Cassandra.Conversation.MLS (lookupMLSClients) +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.Store (embedClient) +import Galley.Effects.SubConversationStore (SubConversationStore (..)) +import Imports +import Polysemy +import Polysemy.Input +import Wire.API.Conversation.Protocol +import Wire.API.MLS.CipherSuite +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 = do + m <- retry x5 (query1 Cql.selectSubConversation (params LocalQuorum (tUnqualified convId, subConvId))) + for m $ \(suite, epoch, groupId) -> do + cm <- lookupMLSClients groupId + pure $ + SubConversation + { scParentConvId = convId, + scSubConvId = subConvId, + scMLSData = + ConversationMLSData + { cnvmlsGroupId = groupId, + cnvmlsEpoch = epoch, + cnvmlsCipherSuite = suite + }, + scMembers = cm + } + +insertSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> Epoch -> GroupId -> Maybe OpaquePublicGroupState -> Client () +insertSubConversation convId subConvId suite epoch groupId mPgs = + retry x5 (write Cql.insertSubConversation (params LocalQuorum (convId, subConvId, suite, epoch, groupId, mPgs))) + +updateSubConvPublicGroupState :: ConvId -> SubConvId -> Maybe OpaquePublicGroupState -> Client () +updateSubConvPublicGroupState convId subConvId mPgs = + retry x5 (write Cql.updateSubConvPublicGroupState (params LocalQuorum (convId, subConvId, mPgs))) + +selectSubConvPublicGroupState :: ConvId -> SubConvId -> Client (Maybe OpaquePublicGroupState) +selectSubConvPublicGroupState convId subConvId = + (runIdentity =<<) <$> retry x5 (query1 Cql.selectSubConvPublicGroupState (params LocalQuorum (convId, subConvId))) + +setGroupIdForSubConversation :: GroupId -> Qualified ConvId -> SubConvId -> Client () +setGroupIdForSubConversation groupId qconv sconv = + retry x5 (write Cql.insertGroupIdForSubConversation (params LocalQuorum (groupId, qUnqualified qconv, qDomain qconv, sconv))) + +interpretSubConversationStoreToCassandra :: + Members '[Embed IO, Input ClientState] r => + Sem (SubConversationStore ': r) a -> + Sem r a +interpretSubConversationStoreToCassandra = interpret $ \case + GetSubConversation convId subConvId -> embedClient (selectSubConversation convId subConvId) + CreateSubConversation convId subConvId suite epoch groupId mPgs -> embedClient (insertSubConversation convId subConvId suite epoch groupId mPgs) + 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 diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 05e4997e3c..dd8195e22d 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -81,6 +81,7 @@ import Galley.Effects.Queue import Galley.Effects.SearchVisibilityStore import Galley.Effects.ServiceStore import Galley.Effects.SparAccess +import Galley.Effects.SubConversationStore import Galley.Effects.TeamFeatureStore import Galley.Effects.TeamMemberStore import Galley.Effects.TeamNotificationStore @@ -108,6 +109,7 @@ type GalleyEffects1 = CodeStore, ProposalStore, ConversationStore, + SubConversationStore, CustomBackendStore, LegalHoldStore, MemberStore, diff --git a/services/galley/src/Galley/Effects/ConversationStore.hs b/services/galley/src/Galley/Effects/ConversationStore.hs index 1660c2f689..f8e5336e3a 100644 --- a/services/galley/src/Galley/Effects/ConversationStore.hs +++ b/services/galley/src/Galley/Effects/ConversationStore.hs @@ -28,7 +28,7 @@ module Galley.Effects.ConversationStore -- * Read conversation getConversation, - getConversationIdByGroupId, + lookupConvByGroupId, getConversations, getConversationMetadata, getPublicGroupState, @@ -44,7 +44,7 @@ module Galley.Effects.ConversationStore setConversationMessageTimer, setConversationEpoch, acceptConnectConversation, - setGroupId, + setGroupIdForConversation, setPublicGroupState, -- * Delete conversation @@ -69,6 +69,7 @@ import Polysemy import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.MLS.Epoch import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.SubConversation data ConversationStore m a where CreateConversationId :: ConversationStore m ConvId @@ -78,7 +79,7 @@ data ConversationStore m a where ConversationStore m Conversation DeleteConversation :: ConvId -> ConversationStore m () GetConversation :: ConvId -> ConversationStore m (Maybe Conversation) - GetConversationIdByGroupId :: GroupId -> ConversationStore m (Maybe (Qualified ConvId)) + LookupConvByGroupId :: GroupId -> ConversationStore m (Maybe (Qualified ConvOrSubConvId)) GetConversations :: [ConvId] -> ConversationStore m [Conversation] GetConversationMetadata :: ConvId -> ConversationStore m (Maybe ConversationMetadata) GetPublicGroupState :: @@ -96,7 +97,7 @@ data ConversationStore m a where SetConversationReceiptMode :: ConvId -> ReceiptMode -> ConversationStore m () SetConversationMessageTimer :: ConvId -> Maybe Milliseconds -> ConversationStore m () SetConversationEpoch :: ConvId -> Epoch -> ConversationStore m () - SetGroupId :: GroupId -> Qualified ConvId -> ConversationStore m () + SetGroupIdForConversation :: GroupId -> Qualified ConvId -> ConversationStore m () SetPublicGroupState :: ConvId -> OpaquePublicGroupState -> diff --git a/services/galley/src/Galley/Effects/SubConversationStore.hs b/services/galley/src/Galley/Effects/SubConversationStore.hs new file mode 100644 index 0000000000..46d90b3428 --- /dev/null +++ b/services/galley/src/Galley/Effects/SubConversationStore.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- 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.Effects.SubConversationStore where + +import Data.Id +import Data.Qualified +import Galley.API.MLS.Types +import Imports +import Polysemy +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Epoch +import Wire.API.MLS.Group +import Wire.API.MLS.PublicGroupState +import Wire.API.MLS.SubConversation + +data SubConversationStore m a where + GetSubConversation :: Local 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 () + +makeSem ''SubConversationStore diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 5379b70180..3f11bad6d6 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -204,6 +204,11 @@ tests s = test s "cannot send an MLS message" postMLSMessageDisabled, test s "cannot send a commit bundle" postMLSBundleDisabled, test s "cannot get group info" getGroupInfoDisabled + ], + testGroup + "SubConversation" + [ test s "get subconversation of MLS conv - 200" (testCreateSubConv True), + test s "get subconversation of Proteus conv - 404" (testCreateSubConv False) ] ] @@ -2276,3 +2281,22 @@ getGroupInfoDisabled = do withMLSDisabled $ getGroupInfo (qUnqualified alice) qcnv !!! assertMLSNotEnabled + +testCreateSubConv :: Bool -> TestM () +testCreateSubConv parentIsMLSConv = do + alice <- randomQualifiedUser + runMLSTest $ do + qcnv <- + if parentIsMLSConv + then do + creator <- createMLSClient alice + (_, qcnv) <- setupMLSGroup creator + pure qcnv + else + cnvQualifiedId + <$> liftTest (postConvQualified (qUnqualified alice) defNewProteusConv >>= responseJsonError) + let sconv = SubConvId "call" + liftTest $ + getSubConv (qUnqualified alice) qcnv sconv + !!! do + const (if parentIsMLSConv then 200 else 404) === statusCode diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 132843a524..6174b09abe 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -31,6 +31,7 @@ import qualified Control.Monad.State as State import Control.Monad.Trans.Maybe import Crypto.PubKey.Ed25519 import Data.Aeson.Lens +import Data.Binary.Builder (toLazyByteString) import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.Base64.URL as B64U @@ -60,6 +61,7 @@ import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import TestHelpers import TestSetup +import Web.HttpApiData import Wire.API.Conversation import Wire.API.Conversation.Action import Wire.API.Conversation.Protocol @@ -75,6 +77,7 @@ import Wire.API.MLS.Keys import Wire.API.MLS.Message import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation +import Wire.API.MLS.SubConversation import Wire.API.User.Client import Wire.API.User.Client.Prekey @@ -1040,3 +1043,21 @@ withMLSDisabled :: HasSettingsOverrides m => m a -> m a withMLSDisabled = withSettingsOverrides noMLS where noMLS = Opts.optSettings . Opts.setMlsPrivateKeyPaths .~ Nothing + +getSubConv :: + UserId -> + Qualified ConvId -> + SubConvId -> + TestM ResponseLBS +getSubConv u qcnv sconv = do + g <- viewGalley + get $ + g + . paths + [ "conversations", + toByteString' (qDomain qcnv), + toByteString' (qUnqualified qcnv), + "subconversations", + LBS.toStrict (toLazyByteString (toEncodedUrlPiece sconv)) + ] + . zUser u