MLS: Backend sends remove proposal upon user deletion (#2650)

Co-authored-by: Paolo Capriotti <[email protected]>

Author: smatting

cassandra-schema.cql

@@ -169,7 +169,7 @@ CREATE TABLE galley_test.member (
     conversation_role text,
     hidden boolean,
     hidden_ref text,
-    mls_clients set<text>,
+    mls_clients_keypackages set<frozen<tuple<text, blob>>>,
     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<text>,
+    mls_clients_keypackages set<frozen<tuple<text, blob>>>,
     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

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

docs/src/developer/reference/cassandra-schema.cql

@@ -1 +1 @@
-../../../cassandra-schema.cql
+../../../../cassandra-schema.cql

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)
 

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"
 

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
 

libs/wire-api/src/Wire/API/MLS/KeyPackage.hs

@@ -37,13 +37,15 @@ module Wire.API.MLS.KeyPackage
   )
 where
 
+import Cassandra.CQL hiding (Set)
 import Control.Applicative
 import Control.Lens hiding (set, (.=))
 import Data.Aeson (FromJSON, ToJSON)
 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 =

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)

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

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