Verify commit leaf nodes

changelog.d/5-internal/verify-commit-leaf-nodes

@@ -0,0 +1 @@
+The backend now verifies that new leaf nodes occurring in an MLS commit match the signature key registered by the corresponding client

integration/integration.cabal

@@ -162,6 +162,7 @@ library
     Test.Login
     Test.MessageTimer
     Test.MLS
+    Test.MLS.Clients
     Test.MLS.KeyPackage
     Test.MLS.Keys
     Test.MLS.Message

integration/test/API/BrigInternal.hs

@@ -391,3 +391,9 @@ legalholdLogin domain uid password = do
         [ "user" .= uid,
           "password" .= password
         ]
+
+getMLSClients :: (HasCallStack, MakesValue user) => user -> Ciphersuite -> App Response
+getMLSClients user ciphersuite = do
+  userId <- objId user
+  req <- baseRequest user Brig Unversioned $ joinHttpPath ["i", "mls", "clients", userId]
+  submit "GET" $ req & addQueryParams [("ciphersuite", ciphersuite.code)]

integration/test/MLS/Util.hs

@@ -148,38 +148,40 @@ createWireClient u clientArgs = do
 
 data InitMLSClient = InitMLSClient
   { credType :: CredentialType,
-    clientArgs :: AddClient
+    clientArgs :: AddClient,
+    ciphersuites :: [Ciphersuite]
   }
 
 instance Default InitMLSClient where
-  def = InitMLSClient {credType = BasicCredentialType, clientArgs = def}
+  def = InitMLSClient {credType = BasicCredentialType, clientArgs = def, ciphersuites = [def]}
 
--- | Create new mls client and register with backend.
-createMLSClient :: (MakesValue u, HasCallStack) => Ciphersuite -> InitMLSClient -> u -> App ClientIdentity
-createMLSClient ciphersuite = createMLSClientWithCiphersuites [ciphersuite]
-
--- | Create new mls client and register with backend.
-createMLSClientWithCiphersuites :: (MakesValue u, HasCallStack) => [Ciphersuite] -> InitMLSClient -> u -> App ClientIdentity
-createMLSClientWithCiphersuites ciphersuites opts u = do
-  cid <- createWireClient u opts.clientArgs
+initMLSClient :: InitMLSClient -> ClientIdentity -> App Value
+initMLSClient opts cid = do
   setClientGroupState cid def {credType = opts.credType}
 
   -- set public key
-  suitePKeys <- for ciphersuites $ \ciphersuite -> (ciphersuite,) <$> mlscli Nothing ciphersuite cid ["public-key"] Nothing
+  suitePKeys <- for opts.ciphersuites $ \ciphersuite -> (ciphersuite,) <$> mlscli Nothing ciphersuite cid ["public-key"] Nothing
+  let keys =
+        object
+          [ csSignatureScheme ciphersuite .= T.decodeUtf8 (Base64.encode pkey)
+            | (ciphersuite, pkey) <- suitePKeys
+          ]
   bindResponse
     ( updateClient
         cid
         def
-          { mlsPublicKeys =
-              Just
-                ( object
-                    [ csSignatureScheme ciphersuite .= T.decodeUtf8 (Base64.encode pkey)
-                      | (ciphersuite, pkey) <- suitePKeys
-                    ]
-                )
+          { mlsPublicKeys = Just keys
           }
     )
     $ \resp -> resp.status `shouldMatchInt` 200
+
+  pure keys
+
+-- | Create new mls client and register with backend.
+createMLSClient :: (MakesValue u, HasCallStack) => InitMLSClient -> u -> App ClientIdentity
+createMLSClient opts u = do
+  cid <- createWireClient u opts.clientArgs
+  void $ initMLSClient opts cid
   pure cid
 
 -- | create and upload to backend

integration/test/Test/AccessUpdate.hs

@@ -67,8 +67,8 @@ testAccessUpdateGuestRemoved proto = do
           >>= getJSON 201
       pure (conv, clients)
     ConversationProtocolMLS -> do
-      alice1 <- createMLSClient def def alice
-      clients <- traverse (createMLSClient def def) [bob, charlie, dee]
+      alice1 <- createMLSClient def alice
+      clients <- traverse (createMLSClient def) [bob, charlie, dee]
       traverse_ (uploadNewKeyPackage def) clients
 
       conv <- postConversation alice1 defMLS {team = Just tid} >>= getJSON 201

integration/test/Test/Channels.hs

@@ -34,10 +34,10 @@ testCreateChannelEveryone :: (HasCallStack) => App ()
 testCreateChannelEveryone = do
   (owner, tid, mem : otherTeamMembers) <- createTeam OwnDomain 4
   partner <- createTeamMember owner def {role = "partner"}
-  ownerClient <- createMLSClient def def owner
-  memClient <- createMLSClient def def mem
-  partnerClient <- createMLSClient def def partner
-  otherClients <- for otherTeamMembers $ createMLSClient def def
+  ownerClient <- createMLSClient def owner
+  memClient <- createMLSClient def mem
+  partnerClient <- createMLSClient def partner
+  otherClients <- for otherTeamMembers $ createMLSClient def
   replicateM_ 3 $ for_ (memClient : ownerClient : partnerClient : otherClients) (uploadNewKeyPackage def)
   setTeamFeatureLockStatus owner tid "channels" "unlocked"
   void $ setTeamFeatureConfig owner tid "channels" (config "everyone")
@@ -49,10 +49,10 @@ testCreateChannelMembersOnly :: (HasCallStack) => App ()
 testCreateChannelMembersOnly = do
   (owner, tid, mem : otherTeamMembers) <- createTeam OwnDomain 4
   partner <- createTeamMember owner def {role = "partner"}
-  ownerClient <- createMLSClient def def owner
-  memClient <- createMLSClient def def mem
-  partnerClient <- createMLSClient def def partner
-  otherClients <- for otherTeamMembers $ createMLSClient def def
+  ownerClient <- createMLSClient def owner
+  memClient <- createMLSClient def mem
+  partnerClient <- createMLSClient def partner
+  otherClients <- for otherTeamMembers $ createMLSClient def
   replicateM_ 3 $ for_ (memClient : ownerClient : partnerClient : otherClients) (uploadNewKeyPackage def)
   setTeamFeatureLockStatus owner tid "channels" "unlocked"
   void $ setTeamFeatureConfig owner tid "channels" (config "team-members")
@@ -64,10 +64,10 @@ testCreateChannelAdminsOnly :: (HasCallStack) => App ()
 testCreateChannelAdminsOnly = do
   (owner, tid, mem : otherTeamMembers) <- createTeam OwnDomain 4
   partner <- createTeamMember owner def {role = "partner"}
-  ownerClient <- createMLSClient def def owner
-  memClient <- createMLSClient def def mem
-  partnerClient <- createMLSClient def def partner
-  otherClients <- for otherTeamMembers $ createMLSClient def def
+  ownerClient <- createMLSClient def owner
+  memClient <- createMLSClient def mem
+  partnerClient <- createMLSClient def partner
+  otherClients <- for otherTeamMembers $ createMLSClient def
   replicateM_ 3 $ for_ (memClient : ownerClient : partnerClient : otherClients) (uploadNewKeyPackage def)
   setTeamFeatureLockStatus owner tid "channels" "unlocked"
   void $ setTeamFeatureConfig owner tid "channels" (config "admins")
@@ -78,14 +78,14 @@ testCreateChannelAdminsOnly = do
 testCreateChannelFeatureDisabled :: (HasCallStack) => App ()
 testCreateChannelFeatureDisabled = do
   (owner, tid, _) <- createTeam OwnDomain 1
-  ownerClient <- createMLSClient def def owner
+  ownerClient <- createMLSClient def owner
   void $ uploadNewKeyPackage def ownerClient
   assertCreateChannelFailure "channels-not-enabled" ownerClient tid
 
 testCreateChannelNonTeamConvNotAllowed :: (HasCallStack) => App ()
 testCreateChannelNonTeamConvNotAllowed = do
   user <- randomUser OwnDomain def
-  userClient <- createMLSClient def def user
+  userClient <- createMLSClient def user
   void $ uploadNewKeyPackage def userClient
   postConversation userClient defMLS {groupConvType = Just "channel"} `bindResponse` \resp -> do
     resp.status `shouldMatchInt` 403
@@ -133,7 +133,7 @@ config perms =
 testTeamAdminPermissions :: (HasCallStack) => App ()
 testTeamAdminPermissions = do
   (owner, tid, mem : nonAdmin : mems) <- createTeam OwnDomain 10
-  clients@(ownerClient : memClient : nonAdminClient : _) <- for (owner : mem : nonAdmin : mems) $ createMLSClient def def
+  clients@(ownerClient : memClient : nonAdminClient : _) <- for (owner : mem : nonAdmin : mems) $ createMLSClient def
   for_ clients (uploadNewKeyPackage def)
   setTeamFeatureLockStatus owner tid "channels" "unlocked"
   void $ setTeamFeatureConfig owner tid "channels" (config "everyone")
@@ -224,7 +224,7 @@ testTeamAdminPermissions = do
 testUpdateAddPermissions :: (HasCallStack) => App ()
 testUpdateAddPermissions = do
   (alice, tid, bob : chaz : _) <- createTeam OwnDomain 3
-  clients@(aliceClient : _) <- for [alice, bob, chaz] $ createMLSClient def def
+  clients@(aliceClient : _) <- for [alice, bob, chaz] $ createMLSClient def
   for_ clients (uploadNewKeyPackage def)
   setTeamFeatureLockStatus alice tid "channels" "unlocked"
   void $ setTeamFeatureConfig alice tid "channels" (config "everyone")
@@ -245,7 +245,7 @@ testUpdateAddPermissions = do
 testSetAddPermissionOnChannelCreation :: (HasCallStack) => App ()
 testSetAddPermissionOnChannelCreation = do
   (alice, tid, _) <- createTeam OwnDomain 1
-  aliceClient <- createMLSClient def def alice
+  aliceClient <- createMLSClient def alice
   void $ uploadNewKeyPackage def aliceClient
   setTeamFeatureLockStatus alice tid "channels" "unlocked"
   void $ setTeamFeatureConfig alice tid "channels" (config "everyone")
@@ -260,7 +260,7 @@ testAddPermissionEveryone :: (HasCallStack) => App ()
 testAddPermissionEveryone = do
   (alice, tid, bob : chaz : delia : eric : _) <- createTeam OwnDomain 5
   gunther <- randomUser OwnDomain def
-  clients@(aliceClient : bobClient : chazClient : _ : _ : guntherClient : _) <- for [alice, bob, chaz, delia, eric, gunther] $ createMLSClient def def
+  clients@(aliceClient : bobClient : chazClient : _ : _ : guntherClient : _) <- for [alice, bob, chaz, delia, eric, gunther] $ createMLSClient def
   connectTwoUsers bob gunther
   connectTwoUsers gunther eric
   for_ clients (uploadNewKeyPackage def)
@@ -308,7 +308,7 @@ testFederatedChannel = do
   (bärbel, _, bob : _) <- createTeam OtherDomain 2
   connectTwoUsers alice bärbel
   connectTwoUsers alice bob
-  clients@(aliceClient : _ : bärbelClient : _) <- for [alice, anton, bärbel, bob] $ createMLSClient def def
+  clients@(aliceClient : _ : bärbelClient : _) <- for [alice, anton, bärbel, bob] $ createMLSClient def
   for_ clients (uploadNewKeyPackage def)
 
   setTeamFeatureLockStatus alice teamAlice "channels" "unlocked"
@@ -352,9 +352,9 @@ testWithOldBackendVersion fedDomain = replicateM_ 2 do
   horst <- randomUser fedDomain def
   connectTwoUsers bärbel horst
 
-  bärbelClient <- createMLSClient cs def bärbel
+  bärbelClient <- createMLSClient def {ciphersuites = [cs]} bärbel
   void $ uploadNewKeyPackage cs bärbelClient
-  horstClient <- createMLSClient cs def horst
+  horstClient <- createMLSClient def {ciphersuites = [cs]} horst
   void $ uploadNewKeyPackage cs horstClient
 
   setTeamFeatureLockStatus bärbel tid "channels" "unlocked"
@@ -387,7 +387,7 @@ _testAddtermissionExternalPartner addPermission assertion = do
   setTeamFeatureLockStatus owner tid "channels" "unlocked"
   void $ setTeamFeatureConfig owner tid "channels" (config "everyone")
   partner <- createTeamMember owner def {role = "partner"}
-  clients@(ownerClient : partnerClient : _) <- for (owner : partner : mems) $ createMLSClient def def
+  clients@(ownerClient : partnerClient : _) <- for (owner : partner : mems) $ createMLSClient def
   for_ clients (uploadNewKeyPackage def)
   let p =
         defMLS

integration/test/Test/Events.hs

@@ -168,7 +168,6 @@ testMLSTempEvents = do
   clients@[alice1, _, _] <-
     traverse
       ( createMLSClient
-          def
           def
             { clientArgs =
                 def

integration/test/Test/ExternalPartner.hs

@@ -60,7 +60,7 @@ testExternalPartnerPermissionsMls = do
   -- external partners should not be able to create (MLS) conversations
   (owner, _, _) <- createTeam OwnDomain 2
   bobExt <- createTeamMember owner def {role = "partner"}
-  bobExtClient <- createMLSClient def def bobExt
+  bobExtClient <- createMLSClient def bobExt
   bindResponse (postConversation bobExtClient defMLS) $ \resp -> do
     resp.status `shouldMatchInt` 403
 

integration/test/Test/LegalHold.hs

@@ -1030,7 +1030,7 @@ testBlockLHForMLSUsers = do
   -- if charlie is in any MLS conversation, he cannot approve to be put under legalhold
   (charlie, tid, []) <- createTeam OwnDomain 1
   void $ getSelfConversation charlie
-  [charlie1] <- traverse (createMLSClient def def) [charlie]
+  [charlie1] <- traverse (createMLSClient def) [charlie]
   convId <- createNewGroup def charlie1
   void $ createAddCommit charlie1 convId [charlie] >>= sendAndConsumeCommitBundle
 
@@ -1051,7 +1051,7 @@ testBlockClaimingKeyPackageForLHUsers :: (HasCallStack) => App ()
 testBlockClaimingKeyPackageForLHUsers = do
   (alice, tid, [charlie]) <- createTeam OwnDomain 2
   for_ [alice, charlie] getSelfConversation
-  [alice1, charlie1] <- traverse (createMLSClient def def) [alice, charlie]
+  [alice1, charlie1] <- traverse (createMLSClient def) [alice, charlie]
   _ <- uploadNewKeyPackage def charlie1
   _ <- createNewGroup def alice1
   legalholdWhitelistTeam tid alice >>= assertStatus 200
@@ -1075,7 +1075,7 @@ testBlockCreateMLSConvForLHUsers :: (HasCallStack) => LhApiVersion -> App ()
 testBlockCreateMLSConvForLHUsers v = do
   (alice, tid, [charlie]) <- createTeam OwnDomain 2
   for_ [alice, charlie] getSelfConversation
-  [alice1, charlie1] <- traverse (createMLSClient def def) [alice, charlie]
+  [alice1, charlie1] <- traverse (createMLSClient def) [alice, charlie]
   _ <- uploadNewKeyPackage def alice1
   legalholdWhitelistTeam tid alice >>= assertStatus 200
   withMockServer def (lhMockAppV v) \lhDomAndPort _chan -> do