From 244d021351f9f7c42dfdd06bdbeede5b119c3ba6 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 7 May 2026 16:20:34 +0000 Subject: [PATCH 1/8] added history client column cassandra --- cassandra-schema.cql | 26 +++++++++++++++ services/galley/galley.cabal | 1 + services/galley/src/Galley/Schema/Run.hs | 4 ++- .../src/Galley/Schema/V103_HistoryClient.hs | 33 +++++++++++++++++++ 4 files changed, 63 insertions(+), 1 deletion(-) create mode 100644 services/galley/src/Galley/Schema/V103_HistoryClient.hs diff --git a/cassandra-schema.cql b/cassandra-schema.cql index 7d2e47e16e0..7d917c7045e 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -1632,6 +1632,32 @@ CREATE TABLE galley_test.mls_group_member_client ( AND read_repair = 'BLOCKING' AND speculative_retry = '99p'; +CREATE TABLE galley_test.mls_history_client ( + group_id blob, + id uuid, + key_package_ref blob, + leaf_node_index int, + removal_pending boolean, + PRIMARY KEY (group_id, id) +) WITH CLUSTERING ORDER BY (id ASC) + AND additional_write_policy = '99p' + AND bloom_filter_fp_chance = 0.01 + AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} + AND cdc = false + AND comment = '' + AND compaction = {'class': 'org.apache.cassandra.db.compaction.SizeTieredCompactionStrategy', 'max_threshold': '32', 'min_threshold': '4'} + AND compression = {'chunk_length_in_kb': '16', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} + AND memtable = 'default' + AND crc_check_chance = 1.0 + AND default_time_to_live = 0 + AND extensions = {} + 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 = 'BLOCKING' + AND speculative_retry = '99p'; + CREATE TABLE galley_test.mls_proposal_refs ( group_id blob, epoch bigint, diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 760d46ae5de..4000436cb41 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -109,6 +109,7 @@ library Galley.Schema.V100_OutOfSync Galley.Schema.V101_ConversationLowerGCGracePeriod Galley.Schema.V102_ConversationHistory + Galley.Schema.V103_HistoryClient Galley.Schema.V20 Galley.Schema.V21 Galley.Schema.V22 diff --git a/services/galley/src/Galley/Schema/Run.hs b/services/galley/src/Galley/Schema/Run.hs index 76a76b40175..9d93d530f55 100644 --- a/services/galley/src/Galley/Schema/Run.hs +++ b/services/galley/src/Galley/Schema/Run.hs @@ -23,6 +23,7 @@ import Control.Exception (finally) import Galley.Schema.V100_OutOfSync qualified as V100_OutOfSync import Galley.Schema.V101_ConversationLowerGCGracePeriod qualified as V101_ConversationLowerGCGracePeriod import Galley.Schema.V102_ConversationHistory qualified as V102_ConversationHistory +import Galley.Schema.V103_HistoryClient qualified as V103_HistoryClient import Galley.Schema.V20 qualified as V20 import Galley.Schema.V21 qualified as V21 import Galley.Schema.V22 qualified as V22 @@ -206,7 +207,8 @@ migrations = V99_ConversationAddParent.migration, V100_OutOfSync.migration, V101_ConversationLowerGCGracePeriod.migration, - V102_ConversationHistory.migration + V102_ConversationHistory.migration, + V103_HistoryClient.migration -- FUTUREWORK: once #1726 has made its way to master/production, -- the 'message' field in connections table can be dropped. -- See also https://github.com/wireapp/wire-server/pull/1747/files diff --git a/services/galley/src/Galley/Schema/V103_HistoryClient.hs b/services/galley/src/Galley/Schema/V103_HistoryClient.hs new file mode 100644 index 00000000000..5d8f7d139a9 --- /dev/null +++ b/services/galley/src/Galley/Schema/V103_HistoryClient.hs @@ -0,0 +1,33 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 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.Schema.V103_HistoryClient + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = + Migration 103 "add column history client to mls_group_member_client" $ do + schema' + [r| ALTER TABLE mls_group_member_client ADD ( + history_client_id uuid + ) + |] From 95df347c57ef3b8b2c8cd5ca8f5b49a2ab311991 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 7 May 2026 16:28:11 +0000 Subject: [PATCH 2/8] added history client column to postgres table --- .../20260507162106-history_client.sql | 7 ++++ postgres-schema.sql | 33 +++++++++++++++++-- 2 files changed, 38 insertions(+), 2 deletions(-) create mode 100644 libs/wire-subsystems/postgres-migrations/20260507162106-history_client.sql diff --git a/libs/wire-subsystems/postgres-migrations/20260507162106-history_client.sql b/libs/wire-subsystems/postgres-migrations/20260507162106-history_client.sql new file mode 100644 index 00000000000..a459c6ce54c --- /dev/null +++ b/libs/wire-subsystems/postgres-migrations/20260507162106-history_client.sql @@ -0,0 +1,7 @@ +CREATE TABLE mls_history_client ( + group_id bytea NOT NULL, + id uuid NOT NULL, + leaf_node_index integer NOT NULL, + removal_pending boolean NOT NULL, + PRIMARY KEY (group_id, id) +); diff --git a/postgres-schema.sql b/postgres-schema.sql index 070828aa351..2aabd3b9948 100644 --- a/postgres-schema.sql +++ b/postgres-schema.sql @@ -9,8 +9,8 @@ \restrict 79bbfb4630959c48307653a5cd3d83f2582b3c2210f75f10d79e3ebf0015620 --- Dumped from database version 17.7 --- Dumped by pg_dump version 17.7 +-- Dumped from database version 17.9 +-- Dumped by pg_dump version 17.9 SET statement_timeout = 0; SET lock_timeout = 0; @@ -234,6 +234,20 @@ CREATE TABLE public.mls_group_member_client ( ALTER TABLE public.mls_group_member_client OWNER TO "wire-server"; +-- +-- Name: mls_history_client; Type: TABLE; Schema: public; Owner: wire-server +-- + +CREATE TABLE public.mls_history_client ( + group_id bytea NOT NULL, + id uuid NOT NULL, + leaf_node_index integer NOT NULL, + removal_pending boolean NOT NULL +); + + +ALTER TABLE public.mls_history_client OWNER TO "wire-server"; + -- -- Name: remote_conversation_local_member; Type: TABLE; Schema: public; Owner: wire-server -- @@ -417,6 +431,14 @@ ALTER TABLE ONLY public.mls_group_member_client ADD CONSTRAINT mls_group_member_client_pkey PRIMARY KEY (group_id, user_domain, "user", client); +-- +-- Name: mls_history_client mls_history_client_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server +-- + +ALTER TABLE ONLY public.mls_history_client + ADD CONSTRAINT mls_history_client_pkey PRIMARY KEY (group_id, id); + + -- -- Name: remote_conversation_local_member remote_conversation_local_member_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server -- @@ -508,6 +530,13 @@ CREATE INDEX conversation_codes_key_expires_at_idx ON public.conversation_codes CREATE INDEX conversation_member_user_idx ON public.conversation_member USING btree ("user"); +-- +-- Name: conversation_parent_conv_idx; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX conversation_parent_conv_idx ON public.conversation USING btree (parent_conv); + + -- -- Name: conversation_team_group_type_lower_name_id_idx; Type: INDEX; Schema: public; Owner: wire-server -- From ca92ae7b2db86b1846adff9e47053c29c69a41d3 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 7 May 2026 10:52:05 +0000 Subject: [PATCH 3/8] wip --- .../src/Wire/ConversationSubsystem/MLS/Message.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs index dde9267c7e8..28b6fcc8831 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs @@ -52,6 +52,7 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error +import Wire.API.History import Wire.API.MLS.CipherSuite import Wire.API.MLS.Commit hiding (output) import Wire.API.MLS.CommitBundle @@ -305,6 +306,11 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do lift $ getCommitData senderIdentity lConvOrSub bundle.epoch ciphersuite bundle + let sharedHistoryEnabled = isJust $ historyConfig convOrSub.meta.cnvmHistory + if sharedHistoryEnabled + then todo "check if history client exists" + else todo "check no history client exists" + -- reject message if the conversation is out of sync lift $ do let newUsers = Map.keysSet (unClientMap action.paAdd) From df9b0b665834a3f4fccdb3f1b6e0d6fa8405daf1 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 7 May 2026 13:32:33 +0000 Subject: [PATCH 4/8] wip: extend client identity --- libs/types-common/src/Data/Id.hs | 7 +++ libs/wire-api/src/Wire/API/Error/Galley.hs | 4 +- libs/wire-api/src/Wire/API/MLS/Credential.hs | 29 ++++++++++-- libs/wire-api/src/Wire/API/MLS/KeyPackage.hs | 6 +-- libs/wire-api/src/Wire/API/MLS/Validation.hs | 11 +++-- libs/wire-api/test/unit/Test/Wire/API/MLS.hs | 2 +- .../src/Wire/ConversationStore/Cassandra.hs | 4 +- .../src/Wire/ConversationStore/MLS/Types.hs | 41 +++++++++++++---- .../src/Wire/ConversationStore/Migration.hs | 12 +++-- .../src/Wire/ConversationStore/Postgres.hs | 13 +++++- .../ConversationSubsystem/MLS/Commit/Core.hs | 4 +- .../MLS/Commit/ExternalCommit.hs | 2 +- .../MLS/GroupInfoCheck.hs | 4 +- .../Wire/ConversationSubsystem/MLS/Message.hs | 6 +-- .../ConversationSubsystem/MLS/Proposal.hs | 46 +++++++++++-------- .../Brig/API/MLS/KeyPackages/Validation.hs | 2 +- .../src/Galley/Schema/V103_HistoryClient.hs | 13 ++++-- 17 files changed, 143 insertions(+), 63 deletions(-) diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index 87b51358ae7..a1c0aedf911 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -58,6 +58,7 @@ module Data.Id OAuthRefreshTokenId, ChallengeId, MeetingId, + HistoryClientId, -- * Utils uuidSchema, @@ -116,6 +117,7 @@ data IdTag | Challenge | Job | Meeting + | HistoryClient idTagName :: IdTag -> Text idTagName Asset = "Asset" @@ -132,6 +134,7 @@ idTagName OAuthRefreshToken = "OAuthRefreshToken" idTagName Challenge = "Challenge" idTagName Job = "Job" idTagName Meeting = "Meeting" +idTagName HistoryClient = "HistoryClient" class KnownIdTag (t :: IdTag) where idTagValue :: IdTag @@ -162,6 +165,8 @@ instance KnownIdTag 'Job where idTagValue = Job instance KnownIdTag 'Meeting where idTagValue = Meeting +instance KnownIdTag 'HistoryClient where idTagValue = HistoryClient + type AssetId = Id 'Asset type InvitationId = Id 'Invitation @@ -192,6 +197,8 @@ type JobId = Id 'Job type MeetingId = Id 'Meeting +type HistoryClientId = Id 'HistoryClient + -- Id ------------------------------------------------------------------------- data NoId = NoId deriving (Eq, Show, Generic) diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index 7c57f12f1ab..a01a376c2be 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -631,7 +631,7 @@ data GroupInfoDiagnostics = GroupInfoDiagnostics { commit :: ByteString, groupInfo :: ByteString, groupId :: GroupId, - clients :: [(Int, ClientIdentity)], + clients :: [(Int, GroupMember)], convId :: ConvOrSubConvId, domain :: Domain } @@ -649,7 +649,7 @@ instance APIError GroupInfoDiagnostics where headers = [] } -indexedClientSchema :: ValueSchema NamedSwaggerDoc (Int, ClientIdentity) +indexedClientSchema :: ValueSchema NamedSwaggerDoc (Int, GroupMember) indexedClientSchema = object $ (,) diff --git a/libs/wire-api/src/Wire/API/MLS/Credential.hs b/libs/wire-api/src/Wire/API/MLS/Credential.hs index 607729eb902..ccdb461fa9f 100644 --- a/libs/wire-api/src/Wire/API/MLS/Credential.hs +++ b/libs/wire-api/src/Wire/API/MLS/Credential.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -17,7 +19,7 @@ module Wire.API.MLS.Credential where -import Control.Lens ((?~)) +import Control.Lens (makePrisms, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Binary import Data.Binary.Get @@ -120,10 +122,12 @@ instance ToHttpApiData ClientIdentity where toHeader = encodeMLS' toUrlPiece = T.decodeUtf8 . encodeMLS' +parseId :: Get (Id a) +parseId = maybe (fail "Invalid UUID") (pure . Id) . fromASCIIBytes =<< getByteString 36 + instance ParseMLS ClientIdentity where parseMLS = do - uid <- - maybe (fail "Invalid UUID") (pure . Id) . fromASCIIBytes =<< getByteString 36 + uid <- parseId char ':' cid <- ClientId <$> hexadecimal char '@' @@ -131,6 +135,17 @@ instance ParseMLS ClientIdentity where either fail pure . (mkDomain . T.pack) =<< many' anyChar pure $ ClientIdentity dom uid cid +data GroupMember = RegularClient ClientIdentity | HistoryClient HistoryClientId + deriving (Eq, Show) + +parseHistoryClient :: Get HistoryClientId +parseHistoryClient = string "history-client:" *> parseId + +instance ParseMLS GroupMember where + parseMLS = + (HistoryClient <$> parseHistoryClient) + <|> (RegularClient <$> parseMLS) + -- format of the x509 client identity: {userid}%21{deviceid}@{host} parseX509ClientIdentity :: Get ClientIdentity parseX509ClientIdentity = do @@ -154,3 +169,11 @@ instance SerialiseMLS ClientIdentity where mkClientIdentity :: Qualified UserId -> ClientId -> ClientIdentity mkClientIdentity (Qualified uid domain) = ClientIdentity domain uid + +makePrisms ''GroupMember + +instance ToSchema GroupMember where + schema = + named "GroupMember" $ + tag _RegularClient (unnamed schema) + <> tag _HistoryClient (unnamed schema) diff --git a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs index 1f3e97d1098..741ecf3c571 100644 --- a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs +++ b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs @@ -233,7 +233,7 @@ instance HasField "extensions" KeyPackage [Extension] where instance HasField "leafNode" KeyPackage LeafNode where getField = (.tbs.value.leafNode) -credentialIdentityAndKey :: Credential -> Either Text (ClientIdentity, Maybe X509.PubKey) +credentialIdentityAndKey :: Credential -> Either Text (GroupMember, Maybe X509.PubKey) credentialIdentityAndKey (BasicCredential i) = (,) <$> decodeMLS' i <*> pure Nothing credentialIdentityAndKey (X509Credential certs) = do bs <- case certs of @@ -244,9 +244,9 @@ credentialIdentityAndKey (X509Credential certs) = do X509.decodeSignedCertificate bs -- FUTUREWORK: verify signature let cert = X509.getCertificate signed - certificateIdentityAndKey cert + first RegularClient <$> certificateIdentityAndKey cert -keyPackageIdentity :: KeyPackage -> Either Text ClientIdentity +keyPackageIdentity :: KeyPackage -> Either Text GroupMember keyPackageIdentity kp = fst <$> credentialIdentityAndKey kp.leafNode.credential certificateIdentityAndKey :: X509.Certificate -> Either Text (ClientIdentity, Maybe X509.PubKey) diff --git a/libs/wire-api/src/Wire/API/MLS/Validation.hs b/libs/wire-api/src/Wire/API/MLS/Validation.hs index 6a37f1d0cb8..66bb5e0863b 100644 --- a/libs/wire-api/src/Wire/API/MLS/Validation.hs +++ b/libs/wire-api/src/Wire/API/MLS/Validation.hs @@ -39,7 +39,7 @@ import Wire.API.MLS.Serialisation import Wire.API.MLS.Validation.Error validateKeyPackage :: - Maybe ClientIdentity -> + Maybe GroupMember -> KeyPackage -> Either ValidationError (CipherSuiteTag, Lifetime) validateKeyPackage mIdentity kp = do @@ -79,7 +79,7 @@ validateKeyPackage mIdentity kp = do validateLeafNode :: CipherSuiteTag -> - Maybe ClientIdentity -> + Maybe GroupMember -> LeafNodeTBSExtra -> LeafNode -> Either ValidationError () @@ -99,7 +99,12 @@ validateLeafNode cs mIdentity extra leafNode = do validateSource extra.tag leafNode.source validateCapabilities (credentialTag leafNode.credential) leafNode.capabilities -validateCredential :: CipherSuiteTag -> ByteString -> Maybe ClientIdentity -> Credential -> Either ValidationError () +validateCredential :: + CipherSuiteTag -> + ByteString -> + Maybe GroupMember -> + Credential -> + Either ValidationError () validateCredential cs pkey mIdentity cred = do -- FUTUREWORK: check signature in the case of an x509 credential (identity, mkey) <- diff --git a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs index b6fcf5d945f..0eb770c2d93 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs @@ -89,7 +89,7 @@ testParseKeyPackage = do case keyPackageIdentity kp of Left err -> assertFailure $ "Failed to parse identity: " <> T.unpack err - Right identity -> identity @?= alice + Right identity -> identity @?= RegularClient alice testParseKeyPackageWithCapabilities :: IO () testParseKeyPackageWithCapabilities = do diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs index bc36f8de6bc..cc13e7ba60c 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs @@ -768,7 +768,9 @@ addBotMember s bot cnv = do lookupMLSClientLeafIndices :: GroupId -> Client (ClientMap LeafIndex, IndexMap) lookupMLSClientLeafIndices groupId = do entries <- retry x5 (query Cql.lookupMLSClients (params LocalQuorum (Identity groupId))) - pure $ (mkClientMap &&& mkIndexMap) entries + -- TODO: (leif) lookup history client + historyClientEntries <- todo + pure $ (mkClientMap entries, mkIndexMapFromParts entries historyClientEntries ) lookupMLSClients :: GroupId -> Client (ClientMap LeafIndex) lookupMLSClients = fmap fst . lookupMLSClientLeafIndices diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs b/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs index f3e620ed1de..2a8baf1bd6c 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs @@ -54,6 +54,17 @@ import Wire.API.MLS.LeafNode import Wire.API.MLS.SubConversation import Wire.StoredConversation +mkGroupMember :: + Maybe Domain -> + Maybe UserId -> + Maybe ClientId -> + Maybe HistoryClientId -> + Maybe GroupMember +mkGroupMember (Just dom) (Just uid) (Just cid) Nothing = + Just (RegularClient (ClientIdentity dom uid cid)) +mkGroupMember Nothing Nothing Nothing (Just hid) = Just (HistoryClient hid) +mkGroupMember _ _ _ _ = Nothing + -- | A map of leaf index to members. -- -- This is used to reconstruct client @@ -63,20 +74,29 @@ import Wire.StoredConversation -- Note that clients that are in the process of being removed from a group -- (i.e. there is a pending remove proposals for them) are included in this -- mapping. -newtype IndexMap = IndexMap {unIndexMap :: IntMap ClientIdentity} +newtype IndexMap = IndexMap {unIndexMap :: IntMap GroupMember} deriving (Eq, Show) deriving newtype (Semigroup, Monoid) -mkIndexMap :: [(Domain, UserId, ClientId, Int32, Bool)] -> IndexMap -mkIndexMap = IndexMap . foldr addEntry mempty +mkIndexMapFromParts :: + [(Domain, UserId, ClientId, Int32, Bool)] -> + [(HistoryClientId, Int32, Bool)] -> + IndexMap +mkIndexMapFromParts rows1 rows2 = + IndexMap + . flip (foldr addHistoryClient) rows2 + . flip (foldr addRegularClient) rows1 + $ mempty where - addEntry (dom, usr, c, leafidx, _pending_removal) = - IntMap.insert (fromIntegral leafidx) (ClientIdentity dom usr c) + addHistoryClient (h, leafidx, _) = + IntMap.insert (fromIntegral leafidx) (HistoryClient h) + addRegularClient (dom, usr, c, leafidx, _) = + IntMap.insert (fromIntegral leafidx) (RegularClient (ClientIdentity dom usr c)) -imLookup :: IndexMap -> LeafIndex -> Maybe ClientIdentity +imLookup :: IndexMap -> LeafIndex -> Maybe GroupMember imLookup m i = IntMap.lookup (fromIntegral i) (unIndexMap m) -imFromList :: [(LeafIndex, ClientIdentity)] -> IndexMap +imFromList :: [(LeafIndex, GroupMember)] -> IndexMap imFromList = IndexMap . IntMap.fromList . map (first fromIntegral) imNextIndex :: IndexMap -> LeafIndex @@ -84,10 +104,10 @@ imNextIndex im = fromIntegral . fromJust $ find (\n -> not $ IntMap.member n (unIndexMap im)) [0 ..] -imAddClient :: IndexMap -> ClientIdentity -> (LeafIndex, IndexMap) +imAddClient :: IndexMap -> GroupMember -> (LeafIndex, IndexMap) imAddClient im cid = let idx = imNextIndex im in (idx, IndexMap $ IntMap.insert (fromIntegral idx) cid $ unIndexMap im) -imRemoveClient :: IndexMap -> LeafIndex -> Maybe (ClientIdentity, IndexMap) +imRemoveClient :: IndexMap -> LeafIndex -> Maybe (GroupMember, IndexMap) imRemoveClient im idx = do cid <- imLookup im idx pure (cid, IndexMap . IntMap.delete (fromIntegral idx) $ unIndexMap im) @@ -98,7 +118,7 @@ imRemoveIndices keys = . flip IntMap.withoutKeys (IntSet.fromList (map fromIntegral keys)) . unIndexMap -imAssocs :: IndexMap -> [(Int, ClientIdentity)] +imAssocs :: IndexMap -> [(Int, GroupMember)] imAssocs = IntMap.assocs . unIndexMap -- | A two-level map of users to clients to leaf indices. @@ -111,6 +131,7 @@ imAssocs = IntMap.assocs . unIndexMap -- this mapping. newtype ClientMap a = ClientMap { unClientMap :: Map (Qualified UserId) (Map ClientId a) + -- TODO: add historyClients } deriving (Show, Eq, Functor) diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Migration.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Migration.hs index 4b32b9d0ccc..51986f147d7 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Migration.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Migration.hs @@ -237,6 +237,7 @@ deleteConvFromCassandra allConvData = withCassandra $ do Nothing -> deleteConversation allConvData.conv.id_ Just tid -> deleteTeamConversation tid allConvData.conv.id_ +-- TODO: (leif) migrate history client data saveConvToPostgres :: (PGConstraints r) => AllConvData -> Sem r () saveConvToPostgres allConvData = do let meta = storedConv.metadata @@ -384,11 +385,12 @@ saveConvToPostgres allConvData = do mlsClientRows :: GroupId -> ClientMap LeafIndex -> IndexMap -> [(GroupId, Domain, UserId, ClientId, Int32, Bool)] mlsClientRows gid clientMap indexMap = - let clients :: [(LeafIndex, ClientIdentity, Bool)] = - IntMap.elems $ - IntMap.mapWithKey - (\idx ci -> (fromIntegral idx, ci, isNothing (cmLookupIndex ci clientMap))) - indexMap.unIndexMap + let clients :: [(LeafIndex, ClientIdentity, Bool)] = do + (idx, element) <- IntMap.assocs indexMap.unIndexMap + case element of + RegularClient ci -> + pure (fromIntegral idx, ci, isNothing (cmLookupIndex ci clientMap)) + HistoryClient _ -> [] in flip map clients $ \(idx, ci, removalPending) -> (gid, ci.ciDomain, ci.ciUser, ci.ciClient, fromIntegral idx, removalPending) diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Postgres.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Postgres.hs index 7102b65d4e7..ce4f606ec05 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Postgres.hs @@ -1065,10 +1065,19 @@ selectMLSClients = WHERE group_id = ($1 :: bytea) |] +selectHistoryClients :: Hasql.Statement GroupId [(HistoryClientId, Int32, Bool)] +selectHistoryClients = + dimapPG + [vectorStatement|SELECT (id :: uuid), (leaf_node_index :: integer), (removal_pending :: bool) + FROM mls_history_client + WHERE group_id = ($1 :: bytea) + |] + lookupMLSClientLeafIndicesImpl :: (PGConstraints r) => GroupId -> Sem r (ClientMap LeafIndex, IndexMap) lookupMLSClientLeafIndicesImpl gid = do - rows <- runStatement gid selectMLSClients - pure (mkClientMap rows, mkIndexMap rows) + rows1 <- runStatement gid selectMLSClients + rows2 <- runStatement gid selectHistoryClients + pure (mkClientMap rows1, mkIndexMapFromParts rows1 rows2) -- SUB CONVERSATION OPERATIONS createSubConversationImpl :: (PGConstraints r) => ConvId -> SubConvId -> GroupId -> Sem r SubConversation diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs index a51f0adcbcd..c54c5474cf8 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs @@ -122,7 +122,7 @@ getCommitData senderIdentity lConvOrSub epoch ciphersuite bundle = do runState convOrSub.indexMap $ do creatorAction <- if epoch == Epoch 0 - then addProposedClient (Left senderIdentity.client) + then addProposedClient (Left . RegularClient $ senderIdentity.client) else mempty proposals <- traverse @@ -260,7 +260,7 @@ checkUpdatePath :: checkUpdatePath lConvOrSub senderIdentity ciphersuite path = for_ senderIdentity.index $ \index -> do let groupId = cnvmlsGroupId (tUnqualified lConvOrSub).mlsMeta let extra = LeafNodeTBSExtraCommit groupId index - case validateLeafNode ciphersuite (Just senderIdentity.client) extra path.leaf.value of + case validateLeafNode ciphersuite (Just . RegularClient $ senderIdentity.client) extra path.leaf.value of Left InvalidLeafNodeSignature -> throwS @'MLSInvalidLeafNodeSignature Left errMsg -> throw $ diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs index 10fa4e6bd58..c711391146c 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs @@ -114,7 +114,7 @@ getExternalCommitData senderIdentity lConvOrSub epoch commit = do -- add sender client im <- get - let (addedIndex, im') = imAddClient im senderIdentity + let (addedIndex, im') = imAddClient im (RegularClient senderIdentity) put im' pure diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs index d3bdabf3e3b..93773d657f5 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs @@ -45,7 +45,7 @@ import Wire.ConversationStore.MLS.Types import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getFeatureForTeam) data GroupInfoMismatch = GroupInfoMismatch - {clients :: [(Int, ClientIdentity)]} + {clients :: [(Int, GroupMember)]} deriving (Show) newtype GroupInfoCheckEnabled @@ -85,7 +85,7 @@ groupStateMismatch leaves groupInfo = do giLeaves <- imFromList <$> traverse (traverse getIdentity) (ratchetTreeLeaves tree) pure $ guard (leaves /= giLeaves) $> GroupInfoMismatch (imAssocs leaves) where - getIdentity :: LeafNode -> Either Text ClientIdentity + getIdentity :: LeafNode -> Either Text GroupMember getIdentity leaf = fst <$> credentialIdentityAndKey leaf.credential existingGroupStateMismatch :: diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs index 28b6fcc8831..4b1aab10440 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs @@ -307,9 +307,7 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do getCommitData senderIdentity lConvOrSub bundle.epoch ciphersuite bundle let sharedHistoryEnabled = isJust $ historyConfig convOrSub.meta.cnvmHistory - if sharedHistoryEnabled - then todo "check if history client exists" - else todo "check no history client exists" + _ <- todo "check if history client exists" sharedHistoryEnabled -- reject message if the conversation is out of sync lift $ do @@ -497,7 +495,7 @@ getSenderIdentity qusr c mSender lConvOrSubConv = do SenderMember idx -> do when (epoch > 0) $ do cid' <- note (mlsProtocolError "unknown sender leaf index") $ imLookup (tUnqualified lConvOrSubConv).indexMap idx - unless (cid' == cid) $ throwS @'MLSClientSenderUserMismatch + unless (cid' == RegularClient cid) $ throwS @'MLSClientSenderUserMismatch pure (Just idx) _ -> pure Nothing pure SenderIdentity {client = cid, index} diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs index 712fd32aee4..dadb249a32d 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs @@ -79,22 +79,27 @@ import Wire.Util data ProposalAction = ProposalAction { paAdd :: ClientMap (LeafIndex, Maybe KeyPackage), - paRemove :: ClientMap LeafIndex + paRemove :: ClientMap LeafIndex, + paHistoryClientAdd :: Maybe (HistoryClientId, LeafIndex, Maybe KeyPackage), + paHistoryClientRemove :: Maybe (HistoryClientId, LeafIndex) } deriving (Show) +-- TODO: (leif) check this instance Semigroup ProposalAction where - ProposalAction add1 rem1 <> ProposalAction add2 rem2 = - ProposalAction (add1 <> add2) (rem1 <> rem2) + ProposalAction add1 rem1 hadd1 hrem1 <> ProposalAction add2 rem2 hadd2 hrem2 = + ProposalAction (add1 <> add2) (rem1 <> rem2) (hadd1 <|> hadd2) (hrem1 <|> hrem2) instance Monoid ProposalAction where - mempty = ProposalAction mempty mempty + mempty = ProposalAction mempty mempty Nothing Nothing -paAddClient :: ClientIdentity -> LeafIndex -> Maybe KeyPackage -> ProposalAction -paAddClient cid idx kp = mempty {paAdd = cmSingleton cid (idx, kp)} +paAddClient :: GroupMember -> LeafIndex -> Maybe KeyPackage -> ProposalAction +paAddClient (RegularClient cid) idx kp = mempty {paAdd = cmSingleton cid (idx, kp)} +paAddClient (HistoryClient hid) idx kp = mempty {paHistoryClientAdd = Just (hid, idx, kp)} -paRemoveClient :: ClientIdentity -> LeafIndex -> ProposalAction -paRemoveClient cid idx = mempty {paRemove = cmSingleton cid idx} +paRemoveClient :: GroupMember -> LeafIndex -> ProposalAction +paRemoveClient (RegularClient cid) idx = mempty {paRemove = cmSingleton cid idx} +paRemoveClient (HistoryClient hid) idx = mempty {paHistoryClientRemove = Just (hid, idx)} -- | This is used to sort proposals into the correct processing order, as defined by the spec data ProposalProcessingStage @@ -179,7 +184,7 @@ addProposedClient :: ( Member (State IndexMap) r, Member (ErrorS MLSUnsupportedProposal) r ) => - Either ClientIdentity KeyPackage -> + Either GroupMember KeyPackage -> Sem r ProposalAction addProposedClient cidOrKp = do (cid, mKp) <- case cidOrKp of @@ -280,7 +285,7 @@ processProposal qusr lConvOrSub groupId epoch pub prop = do getKeyPackageIdentity :: (Member (ErrorS 'MLSUnsupportedProposal) r) => KeyPackage -> - Sem r ClientIdentity + Sem r GroupMember getKeyPackageIdentity = either (\_ -> throwS @'MLSUnsupportedProposal) pure . keyPackageIdentity @@ -304,15 +309,18 @@ checkExternalProposalUser qusr prop = do loc ( \lusr -> case prop of AddProposal kp -> do - ClientIdentity {ciUser, ciClient} <- getKeyPackageIdentity kp.value - -- requesting user must match key package owner - when (tUnqualified lusr /= ciUser) $ throwS @'MLSUnsupportedProposal - -- client referenced in key package must be one of the user's clients - UserClients {userClients} <- lookupClients [ciUser] - maybe - (throwS @'MLSUnsupportedProposal) - (flip when (throwS @'MLSUnsupportedProposal) . Set.null . Set.filter (== ciClient)) - $ userClients Map.!? ciUser + groupMember <- getKeyPackageIdentity kp.value + case groupMember of + RegularClient (ClientIdentity {ciUser, ciClient}) -> do + -- requesting user must match key package owner + when (tUnqualified lusr /= ciUser) $ throwS @'MLSUnsupportedProposal + -- client referenced in key package must be one of the user's clients + UserClients {userClients} <- lookupClients [ciUser] + maybe + (throwS @'MLSUnsupportedProposal) + (flip when (throwS @'MLSUnsupportedProposal) . Set.null . Set.filter (== ciClient)) + $ userClients Map.!? ciUser + HistoryClient _ -> pure () _ -> throwS @'MLSUnsupportedProposal ) (const $ pure ()) -- FUTUREWORK: check external proposals from remote backends diff --git a/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs b/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs index 09a2fc56bc0..45173c9eb66 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs @@ -53,7 +53,7 @@ validateUploadedKeyPackage :: RawMLS KeyPackage -> Handler r (KeyPackageRef, CipherSuiteTag, KeyPackageData) validateUploadedKeyPackage identity kp = do - (cs, lt) <- either mlsProtocolErrorFromValidationError pure $ validateKeyPackage (Just identity) kp.value + (cs, lt) <- either mlsProtocolErrorFromValidationError pure $ validateKeyPackage (Just $ RegularClient identity) kp.value validateLifetime lt diff --git a/services/galley/src/Galley/Schema/V103_HistoryClient.hs b/services/galley/src/Galley/Schema/V103_HistoryClient.hs index 5d8f7d139a9..a63d4d75920 100644 --- a/services/galley/src/Galley/Schema/V103_HistoryClient.hs +++ b/services/galley/src/Galley/Schema/V103_HistoryClient.hs @@ -25,9 +25,14 @@ import Text.RawString.QQ migration :: Migration migration = - Migration 103 "add column history client to mls_group_member_client" $ do + Migration 103 "add history client table" $ do schema' - [r| ALTER TABLE mls_group_member_client ADD ( - history_client_id uuid - ) + [r| CREATE TABLE mls_history_client ( + group_id blob, + id uuid, + key_package_ref blob, + leaf_node_index int, + removal_pending boolean, + PRIMARY KEY (group_id, id) + ) |] From df8b70e3a1c7481e70b274f1321889a2365d3f36 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 8 May 2026 13:26:15 +0000 Subject: [PATCH 5/8] fix cassandra interpreter and check if history client exists --- libs/wire-api/src/Wire/API/MLS/Credential.hs | 4 ++++ .../src/Wire/ConversationStore/Cassandra.hs | 8 +++----- .../src/Wire/ConversationStore/Cassandra/Queries.hs | 3 +++ .../src/Wire/ConversationSubsystem/MLS/Message.hs | 4 +++- 4 files changed, 13 insertions(+), 6 deletions(-) diff --git a/libs/wire-api/src/Wire/API/MLS/Credential.hs b/libs/wire-api/src/Wire/API/MLS/Credential.hs index ccdb461fa9f..c7ece10f0ef 100644 --- a/libs/wire-api/src/Wire/API/MLS/Credential.hs +++ b/libs/wire-api/src/Wire/API/MLS/Credential.hs @@ -138,6 +138,10 @@ instance ParseMLS ClientIdentity where data GroupMember = RegularClient ClientIdentity | HistoryClient HistoryClientId deriving (Eq, Show) +isHistoryClient :: GroupMember -> Bool +isHistoryClient (HistoryClient _) = True +isHistoryClient (RegularClient _) = False + parseHistoryClient :: Get HistoryClientId parseHistoryClient = string "history-client:" *> parseId diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs index cc13e7ba60c..aa1b4a83b83 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs @@ -27,7 +27,6 @@ import Cassandra import Cassandra qualified as Cql import Cassandra.Settings import Cassandra.Util -import Control.Arrow import Control.Error.Util hiding (hoistMaybe) import Control.Lens import Control.Monad.Trans.Maybe @@ -767,10 +766,9 @@ addBotMember s bot cnv = do lookupMLSClientLeafIndices :: GroupId -> Client (ClientMap LeafIndex, IndexMap) lookupMLSClientLeafIndices groupId = do - entries <- retry x5 (query Cql.lookupMLSClients (params LocalQuorum (Identity groupId))) - -- TODO: (leif) lookup history client - historyClientEntries <- todo - pure $ (mkClientMap entries, mkIndexMapFromParts entries historyClientEntries ) + mlsClients <- retry x5 (query Cql.lookupMLSClients (params LocalQuorum (Identity groupId))) + hClients <- (runIdentity =<<) <$> retry x5 (query1 Cql.lookupHistoryClient (params LocalQuorum (Identity groupId))) + pure $ (mkClientMap mlsClients, mkIndexMapFromParts mlsClients (maybeToList hClients)) lookupMLSClients :: GroupId -> Client (ClientMap LeafIndex) lookupMLSClients = fmap fst . lookupMLSClientLeafIndices diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra/Queries.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra/Queries.hs index ba30f2f8ab9..85bdab7b900 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra/Queries.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra/Queries.hs @@ -355,6 +355,9 @@ removeAllMLSClients = "DELETE FROM mls_group_member_client WHERE group_id = ?" lookupMLSClients :: PrepQuery R (Identity GroupId) (Domain, UserId, ClientId, Int32, Bool) lookupMLSClients = "select user_domain, user, client, leaf_node_index, removal_pending from mls_group_member_client where group_id = ?" +lookupHistoryClient :: PrepQuery R (Identity GroupId) (Identity (Maybe (HistoryClientId, Int32, Bool))) +lookupHistoryClient = "select id, leaf_node_index, removal_pending from mls_history_client where group_id = ?" + acquireCommitLock :: PrepQuery W (GroupId, Epoch, Int32) Row acquireCommitLock = "insert into mls_commit_locks (group_id, epoch) values (?, ?) if not exists using ttl ?" diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs index 4b1aab10440..0cbe0cd0251 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs @@ -27,6 +27,7 @@ where import Control.Monad.Codensity import Data.Domain import Data.Id +import Data.IntMap qualified as IntMap import Data.Json.Util import Data.LegalHold import Data.Map qualified as Map @@ -307,7 +308,8 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do getCommitData senderIdentity lConvOrSub bundle.epoch ciphersuite bundle let sharedHistoryEnabled = isJust $ historyConfig convOrSub.meta.cnvmHistory - _ <- todo "check if history client exists" sharedHistoryEnabled + let historyClientExists = any isHistoryClient (IntMap.elems newIndexMap.unIndexMap) + when (sharedHistoryEnabled /= historyClientExists) $ todo "throw reject commit" -- reject message if the conversation is out of sync lift $ do From 76e0843cbc49ccd37cc8fd87f0e1570c01bcc8a0 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 8 May 2026 14:36:27 +0000 Subject: [PATCH 6/8] added error --- libs/wire-api/src/Wire/API/Error/Galley.hs | 3 +++ .../src/Wire/ConversationSubsystem/Errors.hs | 8 ++++++-- .../src/Wire/ConversationSubsystem/Federation.hs | 3 ++- .../src/Wire/ConversationSubsystem/MLS/Message.hs | 11 +++++++---- 4 files changed, 18 insertions(+), 7 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index a01a376c2be..71b38fc3181 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -179,6 +179,7 @@ data GalleyError | MLSReadReceiptsNotAllowed | MLSInvalidLeafNodeSignature | MeetingNotFound + | MLSHistoryClientConflict deriving (Show, Eq, Generic) deriving (FromJSON, ToJSON) via (CustomEncoded GalleyError) @@ -379,6 +380,8 @@ type instance MapError 'MLSReadReceiptsNotAllowed = 'StaticError 403 "mls-receip type instance MapError 'MLSInvalidLeafNodeSignature = 'StaticError 400 "mls-invalid-leaf-node-signature" "Invalid leaf node signature" +type instance MapError 'MLSHistoryClientConflict = 'StaticError 400 "mls-history-client-conflict" "History sharing settings of the conversation are conflicting with this request" + -------------------------------------------------------------------------------- -- Meeting errors diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs index ec74e2b5267..28c1e81a1e9 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs @@ -103,6 +103,7 @@ data ConversationSubsystemError | ConversationSubsystemErrorMLSOutOfSyncError MLSOutOfSyncError | ConversationSubsystemErrorNonFederatingBackends NonFederatingBackends | ConversationSubsystemErrorUnreachableBackendsLegacy UnreachableBackendsLegacy + | ConversationSubsystemErrorMLSHistoryClientConflict instance APIError ConversationSubsystemError where toResponse = @@ -174,6 +175,7 @@ instance APIError ConversationSubsystemError where ConversationSubsystemErrorMLSOutOfSyncError x -> toResponse x ConversationSubsystemErrorNonFederatingBackends x -> toResponse x ConversationSubsystemErrorUnreachableBackendsLegacy x -> toResponse x + ConversationSubsystemErrorMLSHistoryClientConflict -> toResponse $ Tagged @'MLSHistoryClientConflict () type ConversationSubsystemErrorEffects = '[ ErrorS 'ConvAccessDenied, @@ -244,7 +246,8 @@ type ConversationSubsystemErrorEffects = Error MLSOutOfSyncError, Error MLSProposalFailure, Error NonFederatingBackends, - Error UnreachableBackendsLegacy + Error UnreachableBackendsLegacy, + ErrorS 'MLSHistoryClientConflict ] mapErrors :: @@ -254,7 +257,8 @@ mapErrors :: ) => InterpretersFor ConversationSubsystemErrorEffects r mapErrors = - mapError (ConversationSubsystemErrorUnreachableBackendsLegacy) + mapError (const ConversationSubsystemErrorMLSHistoryClientConflict) + . mapError (ConversationSubsystemErrorUnreachableBackendsLegacy) . mapError (ConversationSubsystemErrorNonFederatingBackends) . interpretServerEffect . mapError (ConversationSubsystemErrorMLSOutOfSyncError) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs index 34a22f5dd4f..1a0c3ee7ba4 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -600,7 +600,8 @@ sendMLSCommitBundle :: Member TeamCollaboratorsSubsystem r, Member E.MLSCommitLockStore r, Member FeaturesConfigSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input ConversationSubsystemConfig) r, + Member (ErrorS 'MLSHistoryClientConflict) r ) => Domain -> MLSMessageSendRequest -> diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs index 0cbe0cd0251..45ee036fa30 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs @@ -172,7 +172,8 @@ postMLSCommitBundle :: Member FederationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (ErrorS 'MLSHistoryClientConflict) r ) => Local x -> Qualified UserId -> @@ -208,7 +209,8 @@ postMLSCommitBundleFromLocalUser :: Member FederationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (ErrorS 'MLSHistoryClientConflict) r ) => Version -> Local UserId -> @@ -244,7 +246,8 @@ postMLSCommitBundleToLocalConv :: Member FederationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (ErrorS 'MLSHistoryClientConflict) r ) => Qualified UserId -> ClientId -> @@ -309,7 +312,7 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do let sharedHistoryEnabled = isJust $ historyConfig convOrSub.meta.cnvmHistory let historyClientExists = any isHistoryClient (IntMap.elems newIndexMap.unIndexMap) - when (sharedHistoryEnabled /= historyClientExists) $ todo "throw reject commit" + lift $ when (sharedHistoryEnabled /= historyClientExists) $ throwS @'MLSHistoryClientConflict -- reject message if the conversation is out of sync lift $ do From 47750406c129206820768ff2ba02f286d5b041cf Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 8 May 2026 14:36:41 +0000 Subject: [PATCH 7/8] test --- integration/test/Test/MLS/History.hs | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/integration/test/Test/MLS/History.hs b/integration/test/Test/MLS/History.hs index 52c94b248a5..eddf75e07fc 100644 --- a/integration/test/Test/MLS/History.hs +++ b/integration/test/Test/MLS/History.hs @@ -137,6 +137,34 @@ testSetHistory = do conv <- getConversation alice convId >>= getJSON 200 conv %. "history" `shouldMatch` history +testHistoryConflict :: App () +testHistoryConflict = do + (alice, tid, [bob]) <- createTeam OwnDomain 2 + + I.setTeamFeatureLockStatus alice tid "channels" "unlocked" + setTeamFeatureConfig alice tid "channels" channelsConfig >>= assertSuccess + + let history = object ["depth" .= "infinite"] + + [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] + void $ uploadNewKeyPackage def bob1 + convId <- + createNewGroupWith + def + alice1 + defMLS + { team = Just tid, + groupConvType = Just "channel" + } + + bindResponse (updateHistory alice convId history) $ \resp -> do + resp.status `shouldMatchInt` 200 + + mp <- createAddCommit alice1 convId [bob] + postMLSCommitBundle mp.sender (mkBundle mp) `bindResponse` \resp -> do + resp.status `shouldMatchInt` 400 + resp.json %. "label" `shouldMatch` "mls-history-client-conflict" + channelsConfig :: Value channelsConfig = object From 32e84afbd46eec32143b844bdb6874ff5d391333 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 8 May 2026 15:32:44 +0000 Subject: [PATCH 8/8] wip: add history client with mlscli --- integration/test/MLS/Util.hs | 67 ++++++++++++++++++++++++------- integration/test/Testlib/Env.hs | 3 +- integration/test/Testlib/Types.hs | 3 +- 3 files changed, 56 insertions(+), 17 deletions(-) diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index cdbd6fcee2c..66020a1475b 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -46,6 +46,7 @@ import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUIDV4 import GHC.Stack import Notifications +import SetupHelpers (randomUUIDString) import System.Directory import System.Exit import System.FilePath @@ -69,6 +70,9 @@ mkClientIdentity u c = do cid2Str :: ClientIdentity -> String cid2Str cid = cid.user <> ":" <> cid.client <> "@" <> cid.domain +hid2Str :: String -> String +hid2Str hid = "history-client:" <> hid + data MessagePackage = MessagePackage { sender :: ClientIdentity, convId :: ConvId, @@ -91,12 +95,22 @@ randomFileName = do (bd ) . UUID.toString <$> liftIO UUIDV4.nextRandom mlscli :: (HasCallStack) => Maybe ConvId -> Ciphersuite -> ClientIdentity -> [String] -> Maybe ByteString -> App ByteString -mlscli mConvId cs cid args mbstdin = do +mlscli mConvId cs cid = mlscli' mConvId cs (Right cid) + +-- TODO: (leif) +mlscli' :: (HasCallStack) => Maybe ConvId -> Ciphersuite -> Either String ClientIdentity -> [String] -> Maybe ByteString -> App ByteString +mlscli' mConvId cs cid args mbstdin = do groupOut <- randomFileName let substOut = argSubst "" groupOut let scheme = csSignatureScheme cs - gs <- getClientGroupState cid + gs <- case cid of + Right cid' -> getClientGroupState cid' + Left _ -> do + convId <- assertOne mConvId + state <- getMLSState + let keyStore = Map.findWithDefault mempty convId state.historyClientState + pure $ ClientGroupState mempty keyStore BasicCredentialType substIn <- case flip Map.lookup gs.groups =<< mConvId of Nothing -> pure id @@ -106,7 +120,7 @@ mlscli mConvId cs cid args mbstdin = do store <- case Map.lookup scheme gs.keystore of Nothing -> do bd <- getBaseDir - liftIO (createDirectory (bd cid2Str cid)) + liftIO (createDirectory (bd either hid2Str cid2Str cid)) `catch` \e -> if (isAlreadyExistsError e) then pure () -- creates a file per signature scheme @@ -115,7 +129,7 @@ mlscli mConvId cs cid args mbstdin = do -- initialise new keystore path <- randomFileName ctype <- make gs.credType & asString - void $ runCli path ["init", "--ciphersuite", cs.code, "-t", ctype, cid2Str cid] Nothing + void $ runCli path ["init", "--ciphersuite", cs.code, "-t", ctype, either hid2Str cid2Str cid] Nothing pure path Just s -> toRandomFile s @@ -136,11 +150,15 @@ mlscli mConvId cs cid args mbstdin = do print =<< liftIO (prettierCallStack callStack) pure id _ -> pure id - setStore <- do - storeData <- liftIO (BS.readFile store) - pure $ \x -> x {keystore = Map.insert scheme storeData x.keystore} + storeData <- liftIO (BS.readFile store) + let setStore x = x {keystore = Map.insert scheme storeData x.keystore} - setClientGroupState cid (setGroup (setStore gs)) + case cid of + Right cid' -> setClientGroupState cid' (setGroup (setStore gs)) + Left _ -> do + convId <- assertOne mConvId + modifyMLSState $ \s -> + s {historyClientState = Map.alter (Just . Map.insert scheme storeData . fromMaybe mempty) convId s.historyClientState} pure out @@ -218,10 +236,19 @@ generateKeyPackage :: (HasCallStack) => ClientIdentity -> Ciphersuite -> App (By generateKeyPackage cid suite = do kp <- mlscli Nothing suite cid ["key-package", "create", "--ciphersuite", suite.code] Nothing ref <- B8.unpack . Base64.encode <$> mlscli Nothing suite cid ["key-package", "ref", "-"] (Just kp) - fp <- keyPackageFile cid ref + fp <- keyPackageFile (cid2Str cid) ref liftIO $ BS.writeFile fp kp pure (kp, ref) +generateHistoryClient :: (HasCallStack) => ConvId -> Ciphersuite -> App (ByteString, String, String) +generateHistoryClient convId suite = do + hid <- randomUUIDString + kp <- mlscli' (Just convId) suite (Left hid) ["key-package", "create", "--ciphersuite", suite.code] Nothing + ref <- B8.unpack . Base64.encode <$> mlscli' (Just convId) suite (Left hid) ["key-package", "ref", "-"] (Just kp) + fp <- keyPackageFile (hid2Str hid) ref + liftIO $ BS.writeFile fp kp + pure (kp, ref, hid) + -- | Create conversation and corresponding group. createNewGroup :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App ConvId createNewGroup cs cid = createNewGroupWith cs cid defMLS @@ -348,11 +375,11 @@ resetClientGroup cs cid gid convId keys = do ] (Just removalKey) -keyPackageFile :: (HasCallStack) => ClientIdentity -> String -> App FilePath -keyPackageFile cid ref = do +keyPackageFile :: (HasCallStack) => String -> String -> App FilePath +keyPackageFile name ref = do let ref' = map urlSafe ref bd <- getBaseDir - pure $ bd cid2Str cid ref' + pure $ bd name ref' where urlSafe '+' = '-' urlSafe '/' = '_' @@ -383,7 +410,7 @@ createAddCommit cid convId users = do kps <- fmap concat . for users $ \user -> do bundle <- claimKeyPackages conv.ciphersuite cid user >>= getJSON 200 unbundleKeyPackages bundle - createAddCommitWithKeyPackages cid convId kps + createAddCommitWithKeyPackages cid convId kps Nothing withTempKeyPackageFile :: ByteString -> ContT a App FilePath withTempKeyPackageFile bs = do @@ -396,19 +423,29 @@ withTempKeyPackageFile bs = do liftIO $ BS.hPut h bs `finally` hClose h k fp +createAddCommitWithHistoryClient :: (HasCallStack) => ClientIdentity -> ConvId -> [Value] -> App MessagePackage +createAddCommitWithHistoryClient cid convId users = do + conv <- getMLSConv convId + kps <- fmap concat . for users $ \user -> do + bundle <- claimKeyPackages conv.ciphersuite cid user >>= getJSON 200 + unbundleKeyPackages bundle + (hckp, _, _) <- generateHistoryClient convId conv.ciphersuite + createAddCommitWithKeyPackages cid convId kps (Just hckp) + createAddCommitWithKeyPackages :: (HasCallStack) => ClientIdentity -> ConvId -> [(ClientIdentity, ByteString)] -> + Maybe ByteString -> App MessagePackage -createAddCommitWithKeyPackages cid convId clientsAndKeyPackages = do +createAddCommitWithKeyPackages cid convId clientsAndKeyPackages hckp = do bd <- getBaseDir welcomeFile <- liftIO $ emptyTempFile bd "welcome" giFile <- liftIO $ emptyTempFile bd "gi" Just conv <- Map.lookup convId . (.convs) <$> getMLSState - commit <- runContT (traverse (withTempKeyPackageFile . snd) clientsAndKeyPackages) $ \kpFiles -> + commit <- runContT (traverse withTempKeyPackageFile (maybeToList hckp <> fmap snd clientsAndKeyPackages)) $ \kpFiles -> mlscli (Just convId) conv.ciphersuite diff --git a/integration/test/Testlib/Env.hs b/integration/test/Testlib/Env.hs index 7d7ad40703e..afb4e211a98 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -217,7 +217,8 @@ mkMLSState = Codensity $ \k -> MLSState { baseDir = tmp, convs = mempty, - clientGroupState = mempty + clientGroupState = mempty, + historyClientState = mempty } getMLSConv :: (HasCallStack) => ConvId -> App MLSConv diff --git a/integration/test/Testlib/Types.hs b/integration/test/Testlib/Types.hs index 9f1d10c13bd..0ca34e5ba52 100644 --- a/integration/test/Testlib/Types.hs +++ b/integration/test/Testlib/Types.hs @@ -358,7 +358,8 @@ instance ToJSON ConvId where data MLSState = MLSState { baseDir :: FilePath, convs :: Map ConvId MLSConv, - clientGroupState :: Map ClientIdentity ClientGroupState + clientGroupState :: Map ClientIdentity ClientGroupState, + historyClientState :: Map ConvId (Map String ByteString) } deriving (Show)