WPB-10207 Match cipher suite tag in query parameters against key packages on replacing key packages

changelog.d/3-bug-fixes/WPB-10207

@@ -0,0 +1 @@
+Match cipher suite tag in query parameters against key packages on replacing key packages

integration/test/API/Brig.hs

@@ -384,13 +384,16 @@ deleteKeyPackages cid kps = do
   submit "DELETE" $ req & addJSONObject ["key_packages" .= kps]
 
 replaceKeyPackages :: ClientIdentity -> [Ciphersuite] -> [ByteString] -> App Response
-replaceKeyPackages cid suites kps = do
+replaceKeyPackages cid suites kps = replaceKeyPackages' cid (Just suites) kps
+
+replaceKeyPackages' :: ClientIdentity -> Maybe [Ciphersuite] -> [ByteString] -> App Response
+replaceKeyPackages' cid mSuites kps = do
   req <-
     baseRequest cid Brig Versioned $
       "/mls/key-packages/self/" <> cid.client
   submit "PUT" $
     req
-      & addQueryParams [("ciphersuites", intercalate "," (map (.code) suites))]
+      & maybe id (\suites -> addQueryParams [("ciphersuites", intercalate "," (map (.code) suites))]) mSuites
       & addJSONObject ["key_packages" .= map (T.decodeUtf8 . Base64.encode) kps]
 
 -- | https://staging-nginz-https.zinfra.io/v6/api/swagger-ui/#/default/get_self

integration/test/Test/MLS/KeyPackage.hs

@@ -277,3 +277,43 @@ testReplaceKeyPackages = do
 
     checkCount def 2
     checkCount suite 2
+
+  do
+    setMLSCiphersuite def
+    defKeyPackages <- replicateM 3 (fmap fst (generateKeyPackage alice1))
+    setMLSCiphersuite suite
+    suiteKeyPackages <- replicateM 3 (fmap fst (generateKeyPackage alice1))
+
+    void $
+      replaceKeyPackages' alice1 (Just []) [] `bindResponse` \resp -> do
+        resp.status `shouldMatchInt` 201
+
+    void $
+      replaceKeyPackages' alice1 Nothing defKeyPackages `bindResponse` \resp -> do
+        resp.status `shouldMatchInt` 201
+
+    checkCount def 3
+    checkCount suite 2
+
+    let testErrorCases :: HasCallStack => Maybe [Ciphersuite] -> [ByteString] -> App ()
+        testErrorCases ciphersuites keyPackages = do
+          void $
+            replaceKeyPackages' alice1 ciphersuites keyPackages `bindResponse` \resp -> do
+              resp.status `shouldMatchInt` 400
+              resp.json %. "label" `shouldMatch` "mls-protocol-error"
+          checkCount def 3
+          checkCount suite 2
+
+    testErrorCases (Just []) defKeyPackages
+    testErrorCases (Just []) suiteKeyPackages
+    testErrorCases Nothing []
+    testErrorCases Nothing suiteKeyPackages
+    testErrorCases Nothing (suiteKeyPackages <> defKeyPackages)
+
+    testErrorCases (Just [suite]) defKeyPackages
+    testErrorCases (Just [suite]) (suiteKeyPackages <> defKeyPackages)
+    testErrorCases (Just [suite]) []
+
+    testErrorCases (Just [def]) suiteKeyPackages
+    testErrorCases (Just [def]) (suiteKeyPackages <> defKeyPackages)
+    testErrorCases (Just [def]) []

services/brig/src/Brig/API/MLS/CipherSuite.hs

@@ -15,12 +15,15 @@
 -- You should have received a copy of the GNU Affero General Public License along
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
-module Brig.API.MLS.CipherSuite (getCipherSuite, getCipherSuites) where
+module Brig.API.MLS.CipherSuite (getCipherSuite, validateCipherSuites) where
 
 import Brig.API.Handler
 import Brig.API.MLS.KeyPackages.Validation
+import Data.Set qualified as Set
 import Imports
 import Wire.API.MLS.CipherSuite
+import Wire.API.MLS.KeyPackage
+import Wire.API.MLS.Serialisation
 
 getOneCipherSuite :: CipherSuite -> Handler r CipherSuiteTag
 getOneCipherSuite s =
@@ -32,5 +35,15 @@ getOneCipherSuite s =
 getCipherSuite :: Maybe CipherSuite -> Handler r CipherSuiteTag
 getCipherSuite = maybe (pure defCipherSuite) getOneCipherSuite
 
-getCipherSuites :: Maybe [CipherSuite] -> Handler r [CipherSuiteTag]
-getCipherSuites = maybe (pure [defCipherSuite]) (traverse getOneCipherSuite)
+validateCipherSuites ::
+  Maybe [CipherSuite] ->
+  KeyPackageUpload ->
+  Handler r (Set CipherSuiteTag)
+validateCipherSuites suites upload = do
+  suitesQuery <- Set.fromList <$> maybe (pure [defCipherSuite]) (traverse getOneCipherSuite) suites
+  when (any isNothing suitesKPM) . void $ mlsProtocolError "uploaded key packages containes unsupported cipher suite"
+  unless (suitesQuery == suitesKP) . void $ mlsProtocolError "uploaded key packages for unannounced cipher suites"
+  pure suitesQuery
+  where
+    suitesKPM = map (cipherSuiteTag . (.cipherSuite) . value) upload.keyPackages
+    suitesKP = Set.fromList $ catMaybes suitesKPM

services/brig/src/Brig/API/MLS/KeyPackages.hs

@@ -168,6 +168,6 @@ replaceKeyPackages ::
   Handler r ()
 replaceKeyPackages lusr c (fmap toList -> mSuites) upload = do
   assertMLSEnabled
-  suites <- getCipherSuites mSuites
+  suites <- validateCipherSuites mSuites upload
   lift $ wrapClient (Data.deleteAllKeyPackages (tUnqualified lusr) c suites)
   uploadKeyPackages lusr c upload

services/brig/src/Brig/Data/MLS/KeyPackage.hs

@@ -145,10 +145,10 @@ deleteKeyPackages u c suite refs =
     deleteQuery = "DELETE FROM mls_key_packages WHERE user = ? AND client = ? AND cipher_suite = ? AND ref in ?"
 
 deleteAllKeyPackages ::
-  (MonadClient m, MonadUnliftIO m) =>
+  (MonadClient m, MonadUnliftIO m, Foldable f) =>
   UserId ->
   ClientId ->
-  [CipherSuiteTag] ->
+  f CipherSuiteTag ->
   m ()
 deleteAllKeyPackages u c suites =
   pooledForConcurrentlyN_ 16 suites $ \suite ->