diff --git a/cassandra-schema.cql b/cassandra-schema.cql index c4666a1071b..f14091ddbd6 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -169,7 +169,7 @@ CREATE TABLE galley_test.member ( conversation_role text, hidden boolean, hidden_ref text, - mls_clients set, + mls_clients_keypackages set>>, otr_archived boolean, otr_archived_ref text, otr_muted boolean, @@ -263,7 +263,7 @@ CREATE TABLE galley_test.member_remote_user ( user_remote_domain text, user_remote_id uuid, conversation_role text, - mls_clients set, + mls_clients_keypackages set>>, PRIMARY KEY (conv, user_remote_domain, user_remote_id) ) WITH CLUSTERING ORDER BY (user_remote_domain ASC, user_remote_id ASC) AND bloom_filter_fp_chance = 0.1 diff --git a/changelog.d/2-features/mls-remove-proposals-on-user-deletion b/changelog.d/2-features/mls-remove-proposals-on-user-deletion new file mode 100644 index 00000000000..cacb36e122a --- /dev/null +++ b/changelog.d/2-features/mls-remove-proposals-on-user-deletion @@ -0,0 +1 @@ +External remove proposals are now sent to a group when a user is deleted diff --git a/docs/src/developer/reference/cassandra-schema.cql b/docs/src/developer/reference/cassandra-schema.cql index 0939aa54a6e..8382d360503 120000 --- a/docs/src/developer/reference/cassandra-schema.cql +++ b/docs/src/developer/reference/cassandra-schema.cql @@ -1 +1 @@ -../../../cassandra-schema.cql \ No newline at end of file +../../../../cassandra-schema.cql \ No newline at end of file diff --git a/libs/galley-types/src/Galley/Types/Conversations/Members.hs b/libs/galley-types/src/Galley/Types/Conversations/Members.hs index 12926efced7..9c6b9b5eb0a 100644 --- a/libs/galley-types/src/Galley/Types/Conversations/Members.hs +++ b/libs/galley-types/src/Galley/Types/Conversations/Members.hs @@ -37,13 +37,14 @@ import qualified Data.Set as Set import Imports import Wire.API.Conversation import Wire.API.Conversation.Role (RoleName, roleNameWireAdmin) +import Wire.API.MLS.KeyPackage import Wire.API.Provider.Service (ServiceRef) -- | Internal (cassandra) representation of a remote conversation member. data RemoteMember = RemoteMember { rmId :: Remote UserId, rmConvRoleName :: RoleName, - rmMLSClients :: Set ClientId + rmMLSClients :: Set (ClientId, KeyPackageRef) } deriving stock (Show) @@ -64,7 +65,7 @@ data LocalMember = LocalMember lmStatus :: MemberStatus, lmService :: Maybe ServiceRef, lmConvRoleName :: RoleName, - lmMLSClients :: Set ClientId + lmMLSClients :: Set (ClientId, KeyPackageRef) } deriving stock (Show) diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index 7ba3239c8b0..f6344289905 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -192,7 +192,7 @@ type instance MapError 'MLSClientMismatch = 'StaticError 409 "mls-client-mismatc type instance MapError 'MLSStaleMessage = 'StaticError 409 "mls-stale-message" "The conversation epoch in a message is too old" -type instance MapError 'MLSCommitMissingReferences = 'StaticError 409 "mls-commit-missing-references" "The commit is not refrencing all pending proposals" +type instance MapError 'MLSCommitMissingReferences = 'StaticError 409 "mls-commit-missing-references" "The commit is not referencing all pending proposals" type instance MapError 'MLSSelfRemovalNotAllowed = 'StaticError 409 "mls-self-removal-not-allowed" "Self removal from group is not allowed" diff --git a/libs/wire-api/src/Wire/API/MLS/Credential.hs b/libs/wire-api/src/Wire/API/MLS/Credential.hs index 6cd03be33fc..c3cb28c6c5e 100644 --- a/libs/wire-api/src/Wire/API/MLS/Credential.hs +++ b/libs/wire-api/src/Wire/API/MLS/Credential.hs @@ -19,6 +19,7 @@ module Wire.API.MLS.Credential where +import Cassandra.CQL import Control.Error.Util import Control.Lens ((?~)) import Data.Aeson (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) @@ -84,6 +85,14 @@ data SignatureSchemeTag = Ed25519 deriving stock (Bounded, Enum, Eq, Ord, Show, Generic) deriving (Arbitrary) via GenericUniform SignatureSchemeTag +instance Cql SignatureSchemeTag where + ctype = Tagged TextColumn + toCql = CqlText . signatureSchemeName + fromCql (CqlText name) = + note ("Unexpected signature scheme: " <> T.unpack name) $ + signatureSchemeFromName name + fromCql _ = Left "SignatureScheme: Text expected" + signatureSchemeNumber :: SignatureSchemeTag -> Word16 signatureSchemeNumber Ed25519 = 0x807 diff --git a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs index 3d39d778c5f..ae4dd7a1552 100644 --- a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs +++ b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs @@ -37,6 +37,7 @@ module Wire.API.MLS.KeyPackage ) where +import Cassandra.CQL hiding (Set) import Control.Applicative import Control.Lens hiding (set, (.=)) import Data.Aeson (FromJSON, ToJSON) @@ -44,6 +45,7 @@ import Data.Binary import Data.Binary.Get import Data.Binary.Put import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LBS import Data.Id import Data.Json.Util import Data.Qualified @@ -79,6 +81,12 @@ instance ToSchema KeyPackageData where .= named "KeyPackage" base64Schema ) +instance Cql KeyPackageData where + ctype = Tagged BlobColumn + toCql = CqlBlob . LBS.fromStrict . kpData + fromCql (CqlBlob b) = pure . KeyPackageData . LBS.toStrict $ b + fromCql _ = Left "Expected CqlBlob" + data KeyPackageBundleEntry = KeyPackageBundleEntry { kpbeUser :: Qualified UserId, kpbeClient :: ClientId, @@ -132,6 +140,12 @@ instance ParseMLS KeyPackageRef where instance SerialiseMLS KeyPackageRef where serialiseMLS = putByteString . unKeyPackageRef +instance Cql KeyPackageRef where + ctype = Tagged BlobColumn + toCql = CqlBlob . LBS.fromStrict . unKeyPackageRef + fromCql (CqlBlob b) = pure . KeyPackageRef . LBS.toStrict $ b + fromCql _ = Left "Expected CqlBlob" + -- | Compute key package ref given a ciphersuite and the raw key package data. kpRef :: CipherSuiteTag -> KeyPackageData -> KeyPackageRef kpRef cs = diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 721f63c9c35..28594f36237 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -38,12 +38,11 @@ module Wire.API.MLS.Message MLSMessageSendingStatus (..), KnownFormatTag (..), verifyMessageSignature, - mkRemoveProposalMessage, + mkSignedMessage, ) where import Control.Lens ((?~)) -import Crypto.Error import Crypto.PubKey.Ed25519 import qualified Data.Aeson as A import Data.Binary @@ -341,14 +340,14 @@ verifyMessageSignature :: CipherSuiteTag -> Message 'MLSPlainText -> ByteString verifyMessageSignature cs msg pubkey = csVerifySignature cs pubkey (rmRaw (msgTBS msg)) (msgSignature (msgExtraFields msg)) -mkRemoveProposalMessage :: +mkSignedMessage :: SecretKey -> PublicKey -> GroupId -> Epoch -> - KeyPackageRef -> - Maybe (Message 'MLSPlainText) -mkRemoveProposalMessage priv pub gid epoch ref = maybeCryptoError $ do + MessagePayload 'MLSPlainText -> + Message 'MLSPlainText +mkSignedMessage priv pub gid epoch payload = let tbs = mkRawMLS $ MessageTBS @@ -357,7 +356,7 @@ mkRemoveProposalMessage priv pub gid epoch ref = maybeCryptoError $ do tbsMsgEpoch = epoch, tbsMsgAuthData = mempty, tbsMsgSender = PreconfiguredSender 0, - tbsMsgPayload = ProposalMessage (mkRemoveProposal ref) + tbsMsgPayload = payload } - let sig = BA.convert $ sign priv pub (rmRaw tbs) - pure (Message tbs (MessageExtraFields sig Nothing Nothing)) + sig = BA.convert $ sign priv pub (rmRaw tbs) + in Message tbs (MessageExtraFields sig Nothing Nothing) diff --git a/libs/wire-api/src/Wire/API/MLS/Serialisation.hs b/libs/wire-api/src/Wire/API/MLS/Serialisation.hs index 6510ac31008..a55d9e3fa24 100644 --- a/libs/wire-api/src/Wire/API/MLS/Serialisation.hs +++ b/libs/wire-api/src/Wire/API/MLS/Serialisation.hs @@ -32,6 +32,8 @@ module Wire.API.MLS.Serialisation fromMLSEnum, toMLSEnum', toMLSEnum, + encodeMLS, + encodeMLS', decodeMLS, decodeMLS', decodeMLSWith, @@ -173,6 +175,13 @@ newtype BinaryMLS a = BinaryMLS a instance Binary a => ParseMLS (BinaryMLS a) where parseMLS = BinaryMLS <$> get +-- | Encode an MLS value to a lazy bytestring. +encodeMLS :: SerialiseMLS a => a -> LByteString +encodeMLS = runPut . serialiseMLS + +encodeMLS' :: SerialiseMLS a => a -> ByteString +encodeMLS' = LBS.toStrict . encodeMLS + -- | Decode an MLS value from a lazy bytestring. Return an error message in case of failure. decodeMLS :: ParseMLS a => LByteString -> Either Text a decodeMLS = decodeMLSWith parseMLS 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 d13573dd596..9040f432d49 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs @@ -192,13 +192,27 @@ testRemoveProposalMessageSignature = withSystemTempDirectory "mls" $ \tmp -> do secretKey <- Ed25519.generateSecretKey let publicKey = Ed25519.toPublic secretKey - let message = fromJust (mkRemoveProposalMessage secretKey publicKey gid (Epoch 1) (fromJust (kpRef' kp))) + let message = mkSignedMessage secretKey publicKey gid (Epoch 1) (ProposalMessage (mkRemoveProposal (fromJust (kpRef' kp)))) + let messageFilename = "signed-message.mls" BS.writeFile (tmp messageFilename) (rmRaw (mkRawMLS message)) let signerKeyFilename = "signer-key.bin" BS.writeFile (tmp signerKeyFilename) (convert publicKey) - void . liftIO $ spawn (cli qcid tmp ["check-signature", "--group", tmp groupFilename, "--message", tmp messageFilename, "--signer-key", tmp signerKeyFilename]) Nothing + void . liftIO $ + spawn + ( cli + qcid + tmp + [ "consume", + "--group", + tmp groupFilename, + "--signer-key", + tmp signerKeyFilename, + tmp messageFilename + ] + ) + Nothing createGroup :: FilePath -> String -> String -> GroupId -> IO () createGroup tmp store groupName gid = do diff --git a/services/brig/src/Brig/Data/Instances.hs b/services/brig/src/Brig/Data/Instances.hs index cea0641b7fe..4ec4e3890c1 100644 --- a/services/brig/src/Brig/Data/Instances.hs +++ b/services/brig/src/Brig/Data/Instances.hs @@ -31,20 +31,16 @@ import Control.Error (note) import Data.Aeson (eitherDecode, encode) import qualified Data.Aeson as JSON import Data.ByteString.Conversion -import qualified Data.ByteString.Lazy as LBS import Data.Domain (Domain, domainText, mkDomain) import Data.Handle (Handle (..)) import Data.Id () import Data.Range () import Data.String.Conversions (LBS, ST, cs) -import qualified Data.Text as T import Data.Text.Ascii () import Data.Text.Encoding (encodeUtf8) import Imports import Wire.API.Asset (AssetKey, assetKeyToText, nilAssetKey) import Wire.API.Connection (RelationWithHistory (..)) -import Wire.API.MLS.Credential -import Wire.API.MLS.KeyPackage import Wire.API.Properties import Wire.API.User import Wire.API.User.Activation @@ -283,26 +279,6 @@ instance Cql Domain where fromCql (CqlText txt) = mkDomain txt fromCql _ = Left "Domain: Text expected" -instance Cql SignatureSchemeTag where - ctype = Tagged TextColumn - toCql = CqlText . signatureSchemeName - fromCql (CqlText name) = - note ("Unexpected signature scheme: " <> T.unpack name) $ - signatureSchemeFromName name - fromCql _ = Left "SignatureScheme: Text expected" - -instance Cql KeyPackageRef where - ctype = Tagged BlobColumn - toCql = CqlBlob . LBS.fromStrict . unKeyPackageRef - fromCql (CqlBlob b) = pure . KeyPackageRef . LBS.toStrict $ b - fromCql _ = Left "Expected CqlBlob" - -instance Cql KeyPackageData where - ctype = Tagged BlobColumn - toCql = CqlBlob . LBS.fromStrict . kpData - fromCql (CqlBlob b) = pure . KeyPackageData . LBS.toStrict $ b - fromCql _ = Left "Expected CqlBlob" - instance Cql SearchVisibilityInbound where ctype = Tagged IntColumn diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index f10581474ee..f6c3689b8ff 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -660,6 +660,7 @@ executable galley-schema V68_MLSCommitLock V69_MLSProposal V70_MLSCipherSuite + V71_MemberClientKeypackage hs-source-dirs: schema/src default-extensions: diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index 1d26cc7a89f..e77d65cfed2 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -73,6 +73,7 @@ import qualified V67_MLSFeature import qualified V68_MLSCommitLock import qualified V69_MLSProposal import qualified V70_MLSCipherSuite +import qualified V71_MemberClientKeypackage main :: IO () main = do @@ -131,7 +132,8 @@ main = do V67_MLSFeature.migration, V68_MLSCommitLock.migration, V69_MLSProposal.migration, - V70_MLSCipherSuite.migration + V70_MLSCipherSuite.migration, + V71_MemberClientKeypackage.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/V71_MemberClientKeypackage.hs b/services/galley/schema/src/V71_MemberClientKeypackage.hs new file mode 100644 index 00000000000..1695957905c --- /dev/null +++ b/services/galley/schema/src/V71_MemberClientKeypackage.hs @@ -0,0 +1,50 @@ +-- 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 V71_MemberClientKeypackage where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = + Migration 71 "Replace mls_clients with mls_clients_keypackages in member table" $ do + schema' + [r| + ALTER TABLE member ADD ( + mls_clients_keypackages set>> + ); + |] + schema' + [r| + ALTER TABLE member DROP ( + mls_clients + ); + |] + schema' + [r| + ALTER TABLE member_remote_user ADD ( + mls_clients_keypackages set>> + ); + |] + schema' + [r| + ALTER TABLE member_remote_user DROP ( + mls_clients + ); + |] diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 17e2ee5edf5..85fd3e3c00b 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -40,6 +40,7 @@ import qualified Data.Set as Set import Data.Time import qualified Data.UUID.Tagged as U import Galley.API.Error +import Galley.API.MLS.KeyPackage (nullKeyPackageRef) import Galley.API.Mapping import Galley.API.One2One import Galley.API.Util @@ -117,7 +118,7 @@ createGroupConversation lusr conn newConv = do case (newConvProtocol newConv, newConvCreatorClient newConv) of (ProtocolProteusTag, _) -> pure () (ProtocolMLSTag, Just c) -> - E.addMLSClients lcnv (qUntagged lusr) (Set.singleton c) + E.addMLSClients lcnv (qUntagged lusr) (Set.singleton (c, nullKeyPackageRef)) (ProtocolMLSTag, Nothing) -> throw (InvalidPayload "Missing creator_client field when creating an MLS conversation") diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 6d5714720f1..e43688e0c18 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -23,6 +23,7 @@ module Galley.API.Error InvalidInput (..), InternalError (..), internalErrorWithDescription, + internalErrorDescription, legalHoldServiceUnavailable, -- * Errors thrown by wai-routing handlers @@ -34,6 +35,7 @@ import Data.Id import Data.Text.Lazy as LT (pack) import Imports import Network.HTTP.Types.Status +import Network.Wai.Utilities (Error (message)) import qualified Network.Wai.Utilities.Error as Wai import Wire.API.Error @@ -44,6 +46,9 @@ data InternalError | CannotCreateManagedConv | InternalErrorWithDescription LText +internalErrorDescription :: InternalError -> LText +internalErrorDescription = message . toWai + instance APIError InternalError where toWai (BadConvState convId) = badConvState convId toWai BadMemberState = Wai.mkError status500 "bad-state" "Bad internal member state." diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 4a93480e8cf..2aa7f3a092b 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -62,6 +62,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.Internal.Kind (Append) import Polysemy.Resource +import Polysemy.TinyLog import qualified Polysemy.TinyLog as P import Servant (ServerT) import Servant.API @@ -422,9 +423,13 @@ onUserDeleted :: FireAndForget, ExternalAccess, GundeckAccess, + Error InternalError, Input (Local ()), Input UTCTime, - MemberStore + Input Env, + MemberStore, + ProposalStore, + TinyLog ] r => Domain -> @@ -454,6 +459,7 @@ onUserDeleted origDomain udcn = do Public.RegularConv -> do let action = pure untaggedDeletedUser botsAndMembers = convBotsAndMembers conv + mlsRemoveUser conv (qUntagged deletedUser) void $ notifyConversationAction (sing @'ConversationLeaveTag) @@ -578,6 +584,8 @@ sendMLSMessage remoteDomain msr = . runError . fmap (either (F.MLSMessageResponseProposalFailure . pfInner) id) . runError + . fmap (either (F.MLSMessageResponseProposalFailure . pfInner) id) + . runError $ do loc <- qualifyLocal () let sender = toRemoteUnsafe remoteDomain (F.msrSender msr) diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 04497a56828..120845565a8 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -37,8 +37,10 @@ import GHC.TypeLits (AppendSymbol) import qualified Galley.API.Clients as Clients import qualified Galley.API.Create as Create import qualified Galley.API.CustomBackend as CustomBackend +import Galley.API.Error import Galley.API.LegalHold (unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts +import Galley.API.MLS.Message (mlsRemoveUser) import Galley.API.One2One import Galley.API.Public import Galley.API.Public.Servant @@ -58,6 +60,7 @@ import Galley.Effects.FederatorAccess import Galley.Effects.GundeckAccess import Galley.Effects.LegalHoldStore as LegalHoldStore import Galley.Effects.MemberStore +import Galley.Effects.ProposalStore import Galley.Effects.TeamStore import qualified Galley.Intra.Push as Intra import Galley.Monad @@ -629,10 +632,13 @@ rmUser :: FederatorAccess, GundeckAccess, Input UTCTime, + Input Env, ListItems p1 ConvId, ListItems p1 (Remote ConvId), ListItems p2 TeamId, + Input (Local ()), MemberStore, + ProposalStore, TeamStore, P.TinyLog ] @@ -678,6 +684,9 @@ rmUser lusr conn = do ConnectConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing RegularConv | tUnqualified lusr `isMember` Data.convLocalMembers c -> do + runError (mlsRemoveUser c (qUntagged lusr)) >>= \case + Left e -> P.err $ Log.msg ("failed to send remove proposal: " <> internalErrorDescription e) + Right _ -> pure () deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) let e = Event diff --git a/services/galley/src/Galley/API/MLS/KeyPackage.hs b/services/galley/src/Galley/API/MLS/KeyPackage.hs index 2acbab1185a..c5e42031a4b 100644 --- a/services/galley/src/Galley/API/MLS/KeyPackage.hs +++ b/services/galley/src/Galley/API/MLS/KeyPackage.hs @@ -17,6 +17,7 @@ module Galley.API.MLS.KeyPackage where +import qualified Data.ByteString as BS import Galley.Effects.BrigAccess import Imports import Polysemy @@ -25,6 +26,9 @@ import Wire.API.Error.Galley import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage +nullKeyPackageRef :: KeyPackageRef +nullKeyPackageRef = KeyPackageRef (BS.replicate 16 0) + derefKeyPackage :: Members '[ BrigAccess, diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 8e0ea8ef87f..900d91170e2 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -20,12 +20,13 @@ module Galley.API.MLS.Message ( postMLSMessageFromLocalUser, postMLSMessageFromLocalUserV1, postMLSMessage, + mlsRemoveUser, MLSMessageStaticErrors, ) where import Control.Comonad -import Control.Lens (preview, to) +import Control.Lens (preview, to, view) import Data.Bifunctor import Data.Domain import Data.Id @@ -51,6 +52,7 @@ import Galley.Effects.ConversationStore import Galley.Effects.FederatorAccess import Galley.Effects.MemberStore import Galley.Effects.ProposalStore +import Galley.Env import Galley.Options import Galley.Types.Conversations.Members import Imports @@ -76,6 +78,7 @@ import Wire.API.MLS.CipherSuite import Wire.API.MLS.Commit import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Keys import Wire.API.MLS.Message import Wire.API.MLS.Proposal import qualified Wire.API.MLS.Proposal as Proposal @@ -198,48 +201,48 @@ postMLSMessage :: Sem r [LocalConversationUpdate] postMLSMessage loc qusr qcnv con smsg = case rmValue smsg of SomeMessage _ msg -> do - unless (msgEpoch msg == Epoch 0) $ - flip unless (throwS @'MLSClientSenderUserMismatch) =<< isUserSender qusr smsg + mcid <- if msgEpoch msg == Epoch 0 then pure Nothing else getSenderClient smsg + -- 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. + -- + -- This is only relevant in an ongoing conversation. The check should be skipped + -- in case of + -- encrypted messages in which we don't have access to the sending client's + -- key package, + -- messages sent by the backend, and + -- external add proposals which propose fresh key packages for new clients and + -- thus the validity of the key package cannot be known at the time of this + -- check. + -- For these cases the function will return True. + for_ mcid $ \cid -> + when (fmap fst (cidQualifiedClient cid) /= qusr) $ + throwS @'MLSClientSenderUserMismatch + foldQualified loc - (postMLSMessageToLocalConv qusr con smsg) - (postMLSMessageToRemoteConv loc qusr con smsg) + (postMLSMessageToLocalConv qusr (fmap ciClient mcid) con smsg) + (postMLSMessageToRemoteConv loc qusr (fmap ciClient mcid) con smsg) qcnv --- | 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. --- --- This is only relevant in an ongoing conversation. The check should be skipped --- in case of --- * encrypted messages in which we don't have access to the sending client's --- key package, --- * messages sent by the backend, and --- * external add proposals which propose fresh key packages for new clients and --- thus the validity of the key package cannot be known at the time of this --- check. --- For these cases the function will return True. -isUserSender :: +getSenderClient :: ( Members '[ ErrorS 'MLSKeyPackageRefNotFound, BrigAccess ] r ) => - Qualified UserId -> RawMLS SomeMessage -> - Sem r Bool -isUserSender qusr smsg = case rmValue smsg of + Sem r (Maybe ClientIdentity) +getSenderClient smsg = case rmValue smsg of SomeMessage tag msg -> case tag of -- skip encrypted message - SMLSCipherText -> pure True + SMLSCipherText -> pure Nothing SMLSPlainText -> case msgSender msg of -- skip message sent by backend - PreconfiguredSender _ -> pure True + PreconfiguredSender _ -> pure Nothing -- skip external add proposal - NewMemberSender -> pure True - MemberSender ref -> do - ci <- derefKeyPackage ref - pure $ fmap fst (cidQualifiedClient ci) == qusr + NewMemberSender -> pure Nothing + MemberSender ref -> Just <$> derefKeyPackage ref postMLSMessageToLocalConv :: ( HasProposalEffects r, @@ -261,11 +264,12 @@ postMLSMessageToLocalConv :: r ) => Qualified UserId -> + Maybe ClientId -> Maybe ConnId -> RawMLS SomeMessage -> Local ConvId -> Sem r [LocalConversationUpdate] -postMLSMessageToLocalConv qusr con smsg lcnv = case rmValue smsg of +postMLSMessageToLocalConv qusr senderClient con smsg lcnv = case rmValue smsg of SomeMessage tag msg -> do conv <- getConversation (tUnqualified lcnv) >>= noteS @'ConvNotFound @@ -278,7 +282,7 @@ postMLSMessageToLocalConv qusr con smsg lcnv = case rmValue smsg of events <- case tag of SMLSPlainText -> case msgPayload msg of CommitMessage c -> - processCommit qusr con (qualifyAs lcnv conv) (msgEpoch msg) (msgSender msg) c + processCommit qusr senderClient con (qualifyAs lcnv conv) (msgEpoch msg) (msgSender msg) c ApplicationMessage _ -> throwS @'MLSUnsupportedMessage ProposalMessage prop -> processProposal qusr conv msg prop $> mempty @@ -300,11 +304,12 @@ postMLSMessageToRemoteConv :: ) => Local x -> Qualified UserId -> + Maybe ClientId -> Maybe ConnId -> RawMLS SomeMessage -> Remote ConvId -> Sem r [LocalConversationUpdate] -postMLSMessageToRemoteConv loc qusr con smsg rcnv = do +postMLSMessageToRemoteConv loc qusr _senderClient con smsg rcnv = 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 @@ -346,7 +351,7 @@ type HasProposalEffects r = Member TeamStore r ) -type ClientMap = Map (Qualified UserId) (Set ClientId) +type ClientMap = Map (Qualified UserId) (Set (ClientId, KeyPackageRef)) data ProposalAction = ProposalAction { paAdd :: ClientMap, @@ -362,10 +367,10 @@ instance Semigroup ProposalAction where instance Monoid ProposalAction where mempty = ProposalAction mempty mempty -paAddClient :: Qualified (UserId, ClientId) -> ProposalAction +paAddClient :: Qualified (UserId, (ClientId, KeyPackageRef)) -> ProposalAction paAddClient quc = mempty {paAdd = Map.singleton (fmap fst quc) (Set.singleton (snd (qUnqualified quc)))} -paRemoveClient :: Qualified (UserId, ClientId) -> ProposalAction +paRemoveClient :: Qualified (UserId, (ClientId, KeyPackageRef)) -> ProposalAction paRemoveClient quc = mempty {paRemove = Map.singleton (fmap fst quc) (Set.singleton (snd (qUnqualified quc)))} processCommit :: @@ -384,13 +389,14 @@ processCommit :: Member Resource r ) => Qualified UserId -> + Maybe ClientId -> Maybe ConnId -> Local Data.Conversation -> Epoch -> Sender 'MLSPlainText -> Commit -> Sem r [LocalConversationUpdate] -processCommit qusr con lconv epoch sender commit = do +processCommit qusr senderClient con lconv epoch sender commit = do self <- noteS @'ConvNotFound $ getConvMember lconv (tUnqualified lconv) qusr -- check epoch number @@ -411,7 +417,7 @@ processCommit qusr con lconv epoch sender commit = do then do -- this is a newly created conversation, and it should contain exactly one -- client (the creator) - case (sender, first (toList . lmMLSClients) self) of + case (sender, first (fmap fst . toList . lmMLSClients) self) of (MemberSender currentRef, Left [creatorClient]) -> do -- use update path as sender reference and if not existing fall back to sender senderRef <- @@ -423,11 +429,7 @@ processCommit qusr con lconv epoch sender commit = do ) $ cPath commit -- register the creator client - addKeyPackageRef - senderRef - qusr - creatorClient - (qUntagged (fmap Data.convId lconv)) + updateKeyPackageMapping lconv qusr creatorClient Nothing senderRef -- remote clients cannot send the first commit (_, Right _) -> throwS @'MLSStaleMessage -- uninitialised conversations should contain exactly one client @@ -440,11 +442,9 @@ processCommit qusr con lconv epoch sender commit = do (MemberSender senderRef, Just updatedKeyPackage) -> do updatedRef <- kpRef' updatedKeyPackage & note (mlsProtocolError "Could not compute key package ref") -- postpone key package ref update until other checks/processing passed - pure . updateKeyPackageRef $ - KeyPackageUpdate - { kpupPrevious = senderRef, - kpupNext = updatedRef - } + case senderClient of + Just cli -> pure $ updateKeyPackageMapping lconv qusr cli (Just senderRef) updatedRef + Nothing -> pure $ pure () (_, Nothing) -> pure $ pure () -- ignore commits without update path _ -> throw (mlsProtocolError "Unexpected sender") @@ -465,6 +465,33 @@ processCommit qusr con lconv epoch sender commit = do pure updates +updateKeyPackageMapping :: + Members '[BrigAccess, MemberStore] r => + Local Data.Conversation -> + Qualified UserId -> + ClientId -> + Maybe KeyPackageRef -> + KeyPackageRef -> + Sem r () +updateKeyPackageMapping lconv qusr cid mOld new = do + let lcnv = fmap Data.convId lconv + -- update actual mapping in brig + case mOld of + Nothing -> + addKeyPackageRef new qusr cid (qUntagged lcnv) + Just old -> + updateKeyPackageRef + KeyPackageUpdate + { kpupPrevious = old, + kpupNext = new + } + + -- remove old (client, key package) pair + let old = fromMaybe nullKeyPackageRef mOld + removeMLSClients lcnv qusr (Set.singleton (cid, old)) + -- add new (client, key package) pair + addMLSClients lcnv qusr (Set.singleton (cid, new)) + applyProposalRef :: ( HasProposalEffects r, Members @@ -498,10 +525,10 @@ applyProposal (AddProposal kp) = do kpRef' kp & note (mlsProtocolError "Could not compute ref of a key package in an Add proposal") qclient <- cidQualifiedClient <$> derefKeyPackage ref - pure (paAddClient qclient) + pure (paAddClient ((,ref) <$$> qclient)) applyProposal (RemoveProposal ref) = do qclient <- cidQualifiedClient <$> derefKeyPackage ref - pure (paRemoveClient qclient) + pure (paRemoveClient ((,ref) <$$> qclient)) applyProposal _ = pure mempty checkProposalCipherSuite :: @@ -673,7 +700,7 @@ executeProposalAction qusr con lconv action = do -- new user Nothing -> do -- final set of clients in the conversation - let clients = newclients <> Map.findWithDefault mempty qtarget cm + let clients = Set.map fst (newclients <> Map.findWithDefault mempty qtarget cm) -- get list of mls clients from brig clientInfo <- getMLSClients lconv qtarget ss let allClients = Set.map ciId clientInfo @@ -700,19 +727,29 @@ executeProposalAction qusr con lconv action = do -- add users to the conversation and send events addEvents <- foldMap addMembers . nonEmpty . map fst $ newUserClients - -- add clients to the database + + -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do addMLSClients (fmap convId lconv) qtarget newClients -- remove users from the conversation and send events removeEvents <- foldMap removeMembers (nonEmpty membersToRemove) + -- remove clients in the conversation state + for_ removeUserClients $ \(qtarget, clients) -> do + removeMLSClients (fmap convId lconv) qtarget clients + pure (addEvents <> removeEvents) where -- This also filters out client removals for clients that don't exist anymore -- For these clients there is nothing left to do - checkRemoval :: Local x -> SignatureSchemeTag -> Qualified UserId -> Set ClientId -> Sem r (Maybe (Qualified UserId)) - checkRemoval loc ss qtarget clients = do + checkRemoval :: + Local x -> + SignatureSchemeTag -> + Qualified UserId -> + Set (ClientId, KeyPackageRef) -> + Sem r (Maybe (Qualified UserId)) + checkRemoval loc ss qtarget (Set.map fst -> clients) = do allClients <- Set.map ciId <$> getMLSClients loc qtarget ss let allClientsDontExist = Set.null (clients `Set.intersection` allClients) if allClientsDontExist @@ -814,13 +851,13 @@ propagateMessage loc qusr conv con raw = do cToList (u, s) = (u,) <$> Set.toList s clients :: LocalMember -> Local (UserId, Set ClientId) - clients LocalMember {..} = qualifyAs loc (lmId, lmMLSClients) + clients LocalMember {..} = qualifyAs loc (lmId, Set.map fst lmMLSClients) remoteMemberMLSClients :: RemoteMember -> [(UserId, ClientId)] remoteMemberMLSClients rm = map (tUnqualified (rmId rm),) - (toList (rmMLSClients rm)) + (toList (Set.map fst (rmMLSClients rm))) handleError :: Member TinyLog r => Either (Remote [a], FederationError) x -> Sem r () handleError (Right _) = pure () @@ -943,3 +980,39 @@ withCommitLock gid epoch ttl action = ) (const $ releaseCommitLock gid epoch) (const action) + +mlsRemoveUser :: + ( Members + '[ Input UTCTime, + TinyLog, + ExternalAccess, + FederatorAccess, + GundeckAccess, + Error InternalError, + ProposalStore, + Input Env, + Input (Local ()) + ] + r + ) => + Data.Conversation -> + Qualified UserId -> + Sem r () +mlsRemoveUser c qusr = do + loc <- qualifyLocal () + case Data.convProtocol c of + ProtocolProteus -> pure () + ProtocolMLS meta -> do + keyPair <- mlsKeyPair_ed25519 <$> (inputs (view mlsKeys) <*> pure RemovalPurpose) + (secKey, pubKey) <- note (InternalErrorWithDescription "backend removal key missing") $ keyPair + for_ (getConvMemberMLSClients loc c qusr) $ \cpks -> + for_ cpks $ \(_client, 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) + proposal + propagateMessage loc qusr c Nothing msgEncoded diff --git a/services/galley/src/Galley/Cassandra.hs b/services/galley/src/Galley/Cassandra.hs index 4d70622b88b..e256f18aba0 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 = 70 +schemaVersion = 71 diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index 12fa07c4d17..25e2a3cb3db 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -46,6 +46,7 @@ import Polysemy.Input import qualified UnliftIO import Wire.API.Conversation.Member hiding (Member) import Wire.API.Conversation.Role +import Wire.API.MLS.KeyPackage import Wire.API.Provider.Service -- | Add members to a local conversation. @@ -157,7 +158,7 @@ toMember :: Maybe Text, -- conversation role name Maybe RoleName, - Maybe (Cassandra.Set ClientId) + Maybe (Cassandra.Set (ClientId, KeyPackageRef)) ) -> Maybe LocalMember toMember (usr, srv, prv, Just 0, omus, omur, oar, oarr, hid, hidr, crn, cs) = @@ -344,14 +345,14 @@ removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victim setConsistency LocalQuorum for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) -addMLSClients :: Local ConvId -> Qualified UserId -> Set.Set ClientId -> Client () +addMLSClients :: Local ConvId -> Qualified UserId -> Set.Set (ClientId, KeyPackageRef) -> Client () addMLSClients lcnv = foldQualified lcnv (addLocalMLSClients (tUnqualified lcnv)) (addRemoteMLSClients (tUnqualified lcnv)) -addRemoteMLSClients :: ConvId -> Remote UserId -> Set.Set ClientId -> Client () +addRemoteMLSClients :: ConvId -> Remote UserId -> Set.Set (ClientId, KeyPackageRef) -> Client () addRemoteMLSClients cid ruid cs = retry x5 $ write @@ -361,7 +362,7 @@ addRemoteMLSClients cid ruid cs = (Cassandra.Set (toList cs), cid, tDomain ruid, tUnqualified ruid) ) -addLocalMLSClients :: ConvId -> Local UserId -> Set.Set ClientId -> Client () +addLocalMLSClients :: ConvId -> Local UserId -> Set.Set (ClientId, KeyPackageRef) -> Client () addLocalMLSClients cid lusr cs = retry x5 $ write @@ -371,6 +372,33 @@ addLocalMLSClients cid lusr cs = (Cassandra.Set (toList cs), cid, tUnqualified lusr) ) +removeMLSClients :: Local ConvId -> Qualified UserId -> Set.Set (ClientId, KeyPackageRef) -> Client () +removeMLSClients lcnv = + foldQualified + lcnv + (removeLocalMLSClients (tUnqualified lcnv)) + (removeRemoteMLSClients (tUnqualified lcnv)) + +removeLocalMLSClients :: ConvId -> Local UserId -> Set.Set (ClientId, KeyPackageRef) -> Client () +removeLocalMLSClients cid lusr cs = + retry x5 $ + write + Cql.removeLocalMLSClients + ( params + LocalQuorum + (Cassandra.Set (toList cs), cid, tUnqualified lusr) + ) + +removeRemoteMLSClients :: ConvId -> Remote UserId -> Set.Set (ClientId, KeyPackageRef) -> Client () +removeRemoteMLSClients cid rusr cs = + retry x5 $ + write + Cql.removeRemoteMLSClients + ( params + LocalQuorum + (Cassandra.Set (toList cs), cid, tDomain rusr, tUnqualified rusr) + ) + interpretMemberStoreToCassandra :: Members '[Embed IO, Input ClientState] r => Sem (MemberStore ': r) a -> @@ -394,3 +422,4 @@ interpretMemberStoreToCassandra = interpret $ \case embedClient $ removeLocalMembersFromRemoteConv rcnv uids AddMLSClients lcnv quid cs -> embedClient $ addMLSClients lcnv quid cs + RemoveMLSClients lcnv quid cs -> embedClient $ removeMLSClients lcnv quid cs diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index 5d77b62df40..c46fb5afdb3 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -34,6 +34,7 @@ import Wire.API.Conversation.Code import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.MLS.CipherSuite +import Wire.API.MLS.KeyPackage import Wire.API.Provider import Wire.API.Provider.Service import Wire.API.Team @@ -271,14 +272,14 @@ lookupGroupId = "SELECT conv_id, domain from group_id_conv_id where group_id = ? type MemberStatus = Int32 -selectMember :: PrepQuery R (ConvId, UserId) (UserId, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName, Maybe (C.Set ClientId)) -selectMember = "select user, service, provider, status, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role, mls_clients from member where conv = ? and user = ?" +selectMember :: PrepQuery R (ConvId, UserId) (UserId, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName, Maybe (C.Set (ClientId, KeyPackageRef))) +selectMember = "select user, service, provider, status, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role, mls_clients_keypackages from member where conv = ? and user = ?" -selectMembers :: PrepQuery R (Identity ConvId) (UserId, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName, Maybe (C.Set ClientId)) -selectMembers = "select user, service, provider, status, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role, mls_clients from member where conv = ?" +selectMembers :: PrepQuery R (Identity ConvId) (UserId, Maybe ServiceId, Maybe ProviderId, Maybe MemberStatus, Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe RoleName, Maybe (C.Set (ClientId, KeyPackageRef))) +selectMembers = "select user, service, provider, status, otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref, conversation_role, mls_clients_keypackages from member where conv = ?" -insertMember :: PrepQuery W (ConvId, UserId, Maybe ServiceId, Maybe ProviderId, RoleName, Maybe (C.Set ClientId)) () -insertMember = "insert into member (conv, user, service, provider, status, conversation_role, mls_clients) values (?, ?, ?, ?, 0, ?, ?)" +insertMember :: PrepQuery W (ConvId, UserId, Maybe ServiceId, Maybe ProviderId, RoleName, Maybe (C.Set (ClientId, KeyPackageRef))) () +insertMember = "insert into member (conv, user, service, provider, status, conversation_role, mls_clients_keypackages) values (?, ?, ?, ?, 0, ?, ?)" removeMember :: PrepQuery W (ConvId, UserId) () removeMember = "delete from member where conv = ? and user = ?" @@ -307,11 +308,11 @@ insertRemoteMember = "insert into member_remote_user (conv, user_remote_domain, removeRemoteMember :: PrepQuery W (ConvId, Domain, UserId) () removeRemoteMember = "delete from member_remote_user where conv = ? and user_remote_domain = ? and user_remote_id = ?" -selectRemoteMember :: PrepQuery R (ConvId, Domain, UserId) (RoleName, C.Set ClientId) -selectRemoteMember = "select conversation_role, mls_clients from member_remote_user where conv = ? and user_remote_domain = ? and user_remote_id = ?" +selectRemoteMember :: PrepQuery R (ConvId, Domain, UserId) (RoleName, C.Set (ClientId, KeyPackageRef)) +selectRemoteMember = "select conversation_role, mls_clients_keypackages from member_remote_user where conv = ? and user_remote_domain = ? and user_remote_id = ?" -selectRemoteMembers :: PrepQuery R (Identity ConvId) (Domain, UserId, RoleName, C.Set ClientId) -selectRemoteMembers = "select user_remote_domain, user_remote_id, conversation_role, mls_clients from member_remote_user where conv = ?" +selectRemoteMembers :: PrepQuery R (Identity ConvId) (Domain, UserId, RoleName, C.Set (ClientId, KeyPackageRef)) +selectRemoteMembers = "select user_remote_domain, user_remote_id, conversation_role, mls_clients_keypackages from member_remote_user where conv = ?" updateRemoteMemberConvRoleName :: PrepQuery W (RoleName, ConvId, Domain, UserId) () updateRemoteMemberConvRoleName = "update member_remote_user set conversation_role = ? where conv = ? and user_remote_domain = ? and user_remote_id = ?" @@ -367,11 +368,17 @@ rmMemberClient c = -- MLS Clients -------------------------------------------------------------- -addLocalMLSClients :: PrepQuery W (C.Set ClientId, ConvId, UserId) () -addLocalMLSClients = "update member set mls_clients = mls_clients + ? where conv = ? and user = ?" +addLocalMLSClients :: PrepQuery W (C.Set (ClientId, KeyPackageRef), ConvId, UserId) () +addLocalMLSClients = "update member set mls_clients_keypackages = mls_clients_keypackages + ? where conv = ? and user = ?" -addRemoteMLSClients :: PrepQuery W (C.Set ClientId, ConvId, Domain, UserId) () -addRemoteMLSClients = "update member_remote_user set mls_clients = mls_clients + ? where conv = ? and user_remote_domain = ? and user_remote_id = ?" +addRemoteMLSClients :: PrepQuery W (C.Set (ClientId, KeyPackageRef), ConvId, Domain, UserId) () +addRemoteMLSClients = "update member_remote_user set mls_clients_keypackages = mls_clients_keypackages + ? where conv = ? and user_remote_domain = ? and user_remote_id = ?" + +removeLocalMLSClients :: PrepQuery W (C.Set (ClientId, KeyPackageRef), ConvId, UserId) () +removeLocalMLSClients = "update member set mls_clients_keypackages = mls_clients_keypackages - ? where conv = ? and user = ?" + +removeRemoteMLSClients :: PrepQuery W (C.Set (ClientId, KeyPackageRef), ConvId, Domain, UserId) () +removeRemoteMLSClients = "update member_remote_user set mls_clients_keypackages = mls_clients_keypackages - ? where conv = ? and user_remote_domain = ? and user_remote_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/services/galley/src/Galley/Data/Conversation/Types.hs b/services/galley/src/Galley/Data/Conversation/Types.hs index b93bd616c57..5f7add65558 100644 --- a/services/galley/src/Galley/Data/Conversation/Types.hs +++ b/services/galley/src/Galley/Data/Conversation/Types.hs @@ -18,12 +18,14 @@ module Galley.Data.Conversation.Types where import Data.Id +import Data.Qualified import Galley.Types.Conversations.Members import Galley.Types.UserList import Imports import Wire.API.Conversation hiding (Conversation) import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role +import Wire.API.MLS.KeyPackage -- | Internal conversation type, corresponding directly to database schema. -- Should never be sent to users (and therefore doesn't have 'FromJSON' or @@ -43,3 +45,11 @@ data NewConversation = NewConversation ncUsers :: UserList (UserId, RoleName), ncProtocol :: ProtocolTag } + +getConvMemberMLSClients :: Local () -> Conversation -> Qualified UserId -> Maybe (Set (ClientId, KeyPackageRef)) +getConvMemberMLSClients loc conv qusr = + foldQualified + loc + (\lusr -> lmMLSClients <$> find ((==) (tUnqualified lusr) . lmId) (convLocalMembers conv)) + (\rusr -> rmMLSClients <$> find ((==) rusr . rmId) (convRemoteMembers conv)) + qusr diff --git a/services/galley/src/Galley/Effects/MemberStore.hs b/services/galley/src/Galley/Effects/MemberStore.hs index 11dbe2f836e..d9d8c779f87 100644 --- a/services/galley/src/Galley/Effects/MemberStore.hs +++ b/services/galley/src/Galley/Effects/MemberStore.hs @@ -39,6 +39,7 @@ module Galley.Effects.MemberStore setSelfMember, setOtherMember, addMLSClients, + removeMLSClients, -- * Delete members deleteMembers, @@ -55,6 +56,7 @@ import Galley.Types.UserList import Imports import Polysemy import Wire.API.Conversation.Member hiding (Member) +import Wire.API.MLS.KeyPackage import Wire.API.Provider.Service data MemberStore m a where @@ -71,7 +73,8 @@ data MemberStore m a where SetOtherMember :: Local ConvId -> Qualified UserId -> OtherMemberUpdate -> MemberStore m () DeleteMembers :: ConvId -> UserList UserId -> MemberStore m () DeleteMembersInRemoteConversation :: Remote ConvId -> [UserId] -> MemberStore m () - AddMLSClients :: Local ConvId -> Qualified UserId -> Set ClientId -> MemberStore m () + AddMLSClients :: Local ConvId -> Qualified UserId -> Set (ClientId, KeyPackageRef) -> MemberStore m () + RemoveMLSClients :: Local ConvId -> Qualified UserId -> Set (ClientId, KeyPackageRef) -> MemberStore m () makeSem ''MemberStore diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 086a206f7d2..a08bca53ee2 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -153,11 +153,16 @@ tests s = test s "forward an unsupported proposal" propUnsupported ], testGroup - "External Proposal" + "External Add Proposal" [ test s "member adds new client" testExternalAddProposal, test s "non-member adds new client" testExternalAddProposalWrongUser, test s "member adds unknown new client" testExternalAddProposalWrongClient ], + testGroup + "Backend-side External Remove Proposals" + [ test s "local conversation, local user deleted" testBackendRemoveProposalLocalConvLocalUser, + test s "local conversation, remote user deleted" testBackendRemoveProposalLocalConvRemoteUser + ], testGroup "Protocol mismatch" [ test s "send a commit to a proteus conversation" testAddUsersToProteus, @@ -1701,3 +1706,99 @@ propUnsupported = withSystemTempDirectory "mls" $ \tmp -> do postMessage (qUnqualified . pUserId $ creator) msgSerialised !!! const 201 === statusCode + +testBackendRemoveProposalLocalConvLocalUser :: TestM () +testBackendRemoveProposalLocalConvLocalUser = withSystemTempDirectory "mls" $ \tmp -> do + saveRemovalKey (tmp "removal.key") + MessagingSetup {..} <- aliceInvitesBobWithTmp tmp (2, LocalUser) def {createConv = CreateConv} + let [bobParticipant] = users + let bob = pUserId bobParticipant + let alice = pUserId creator + testSuccessfulCommit MessagingSetup {users = [bobParticipant], ..} + + kprefs <- (fromJust . kpRef' . snd) <$$> liftIO (readKeyPackages tmp bobParticipant) + + c <- view tsCannon + WS.bracketR c (qUnqualified alice) $ \wsA -> do + deleteUser (qUnqualified bob) !!! const 200 === statusCode + + for_ kprefs $ \kp -> + WS.assertMatch_ (5 # WS.Second) wsA $ \notification -> do + msg <- wsAssertBackendRemoveProposal bob conversation kp notification + void . liftIO $ + spawn + ( cli + (pClientQid creator) + tmp + $ [ "consume", + "--group", + tmp "group", + "--in-place", + "--signer-key", + tmp "removal.key", + "-" + ] + ) + (Just msg) + + -- alice commits the external proposals + (commit', _) <- liftIO $ pendingProposalsCommit tmp creator "group" + events <- + postCommit + MessagingSetup + { commit = commit', + .. + } + liftIO $ events @?= [] + +testBackendRemoveProposalLocalConvRemoteUser :: TestM () +testBackendRemoveProposalLocalConvRemoteUser = withSystemTempDirectory "mls" $ \tmp -> do + let opts = + def + { createClients = DontCreateClients, + createConv = CreateConv + } + (alice, [bob]) <- + withLastPrekeys $ + setupParticipants tmp opts [(1, RemoteUser (Domain "faraway.example.com"))] + (groupId, conversation) <- setupGroup tmp CreateConv alice "group" + (commit, welcome) <- liftIO $ setupCommit tmp alice "group" "group" (pClients bob) + + let mock req = case frRPC req of + "on-conversation-updated" -> pure (Aeson.encode ()) + "on-new-remote-conversation" -> pure (Aeson.encode EmptyResponse) + "on-mls-message-sent" -> pure (Aeson.encode EmptyResponse) + "get-mls-clients" -> + pure + . Aeson.encode + . Set.fromList + . map (flip ClientInfo True . snd) + . toList + . pClients + $ bob + ms -> assertFailure ("unmocked endpoint called: " <> cs ms) + + void $ + withTempMockFederator' mock $ do + c <- view tsCannon + WS.bracketR c (qUnqualified (pUserId alice)) $ \wsA -> do + void $ postCommit MessagingSetup {creator = alice, users = [bob], ..} + + kprefs <- (fromJust . kpRef' . snd) <$$> liftIO (readKeyPackages tmp bob) + + fedGalleyClient <- view tsFedGalleyClient + void $ + runFedClient + @"on-user-deleted-conversations" + fedGalleyClient + (qDomain (pUserId bob)) + ( UserDeletedConversationsNotification + { udcvUser = qUnqualified (pUserId bob), + udcvConversations = unsafeRange [qUnqualified conversation] + } + ) + + for_ kprefs $ \kp -> + WS.assertMatch_ (5 # WS.Second) wsA $ \notification -> + void $ + wsAssertBackendRemoveProposal (pUserId bob) conversation kp notification diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index c4cca7bf2cd..5e3feaae1f7 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -39,6 +39,8 @@ import qualified Data.Map as Map import Data.Qualified import qualified Data.Set as Set import qualified Data.Text as T +import Galley.Keys +import Galley.Options import Imports import System.FilePath import System.IO.Temp @@ -52,6 +54,7 @@ import Wire.API.Conversation.Protocol import Wire.API.Event.Conversation import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Keys import Wire.API.MLS.Message import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation @@ -142,6 +145,11 @@ pClientQid p = userClientQid (pUserId p) (NonEmpty.head (pClientIds p)) pClientId :: Participant -> ClientId pClientId = NonEmpty.head . pClientIds +readKeyPackages :: FilePath -> Participant -> IO (NonEmpty (ClientId, RawMLS KeyPackage)) +readKeyPackages tmp participant = for (pClients participant) $ \(qcid, cid) -> do + b <- BS.readFile (tmp qcid) + pure (cid, fromRight (error "parsing RawMLS KeyPackage") (decodeMLS' b)) + setupUserClient :: HasCallStack => FilePath -> @@ -606,3 +614,10 @@ mkAppAckProposalMessage gid epoch ref mrs priv pub = do } sig = BA.convert $ sign priv pub (rmRaw tbs) in (Message tbs (MessageExtraFields sig Nothing Nothing)) + +saveRemovalKey :: FilePath -> TestM () +saveRemovalKey fp = do + keys <- fromJust <$> view (tsGConf . optSettings . setMlsPrivateKeyPaths) + keysByPurpose <- liftIO $ loadAllMLSKeys keys + let (_, pub) = fromJust (mlsKeyPair_ed25519 (keysByPurpose RemovalPurpose)) + liftIO $ BS.writeFile fp (BA.convert pub) diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 4556a34a1bd..e24b608ca88 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -111,6 +111,9 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Domain (originDomainHeaderName) import Wire.API.Internal.Notification hiding (target) +import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Message +import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation import Wire.API.Message import qualified Wire.API.Message.Proto as Proto @@ -2760,3 +2763,27 @@ wsAssertConvReceiptModeUpdate conv usr new n = do evtType e @?= ConvReceiptModeUpdate evtFrom e @?= usr evtData e @?= EdConvReceiptModeUpdate (ConversationReceiptModeUpdate new) + +wsAssertBackendRemoveProposal :: HasCallStack => Qualified UserId -> Qualified ConvId -> KeyPackageRef -> Notification -> IO ByteString +wsAssertBackendRemoveProposal fromUser convId kpref n = do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= convId + evtType e @?= MLSMessageAdd + evtFrom e @?= fromUser + let bs = getMLSMessageData (evtData e) + let msg = fromRight (error "Failed to parse Message 'MLSPlaintext") $ decodeMLS' bs + let tbs = rmValue . msgTBS $ msg + tbsMsgSender tbs @?= PreconfiguredSender 0 + case tbsMsgPayload tbs of + ProposalMessage rp -> + case rmValue rp of + RemoveProposal kpRefRemove -> + kpRefRemove @?= kpref + otherProp -> error ("Exepected RemoveProposal but got " <> show otherProp) + otherPayload -> error ("Exepected ProposalMessage but got " <> show otherPayload) + pure bs + where + getMLSMessageData :: Conv.EventData -> ByteString + getMLSMessageData (EdMLSMessage bs) = bs + getMLSMessageData d = error ("Excepected EdMLSMessage, but got " <> show d)