WIP: Huge tangent for MLSState

integration/integration.cabal

@@ -22,7 +22,7 @@ custom-setup
 common common-all
   default-language:   GHC2021
   ghc-options:
-    -Wall -Wpartial-fields -fwarn-tabs -Wno-incomplete-uni-patterns
+    -Wall -Wpartial-fields -fwarn-tabs -Wno-incomplete-uni-patterns -fmax-errors=1
 
   default-extensions:
     AllowAmbiguousTypes

integration/test/Performance/BigConversation.hs

@@ -1,8 +1,51 @@
 module Performance.BigConversation where
 
+import API.BrigCommon
+import Criterion
+import Criterion.Main.Options
+import Criterion.Types
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.Text.Encoding as Text
+import MLS.Util
 import SetupHelpers
+import qualified System.CryptoBox as Cryptobox
 import Testlib.Prelude
+import UnliftIO (pooledMapConcurrentlyN)
+import UnliftIO.Temporary
 
-testBigMLSConversation :: App ()
-testBigMLSConversation = do
-  void $ createTeam OwnDomain 50
+testCreateBigMLSConversation :: App ()
+testCreateBigMLSConversation = do
+  (owner, _tid, members) <- createTeam OwnDomain 20
+  let genPrekeyInBox box i = do
+        pk <- assertCrytoboxSuccess =<< liftIO (Cryptobox.newPrekey box i)
+        pkBS <- liftIO $ Cryptobox.copyBytes pk.prekey
+        pure $ object ["id" .= i, "key" .= Text.decodeUtf8 (B64.encode pkBS)]
+      genPrekeys = do
+        withSystemTempDirectory "cryptobox-prekey-gen" $ \cryptoboxDir -> do
+          box <- assertCrytoboxSuccess =<< liftIO (Cryptobox.open cryptoboxDir)
+          firstPrekey <- genPrekeyInBox box 0
+          lastPrekey <- genPrekeyInBox box maxBound
+          pure (firstPrekey, lastPrekey)
+      createClient user = do
+        (firstPrekey, lastPrekey) <- genPrekeys
+        let mlsClientOpts =
+              def
+                { clientArgs =
+                    def
+                      { prekeys = Just [firstPrekey],
+                        lastPrekey = Just lastPrekey
+                      }
+                }
+        createMLSClient mlsClientOpts user
+  ownerClient <- createClient owner
+  _memClients <- pooledMapConcurrentlyN 64 createClient members
+  createConv <- appToIO $ do
+    (_, _) <- createNewGroup ownerClient
+    void $ sendAndConsumeCommitBundle =<< createAddCommit ownerClient members
+  let benchmarkable = toBenchmarkable (\n -> replicateM_ (fromIntegral n) createConv)
+  liftIO $ benchmarkWith (defaultConfig {resamples = 5}) benchmarkable
+
+assertCrytoboxSuccess :: (Show a) => Cryptobox.Result a -> App a
+assertCrytoboxSuccess = \case
+  Cryptobox.Success x -> pure x
+  e -> assertFailure $ "Cryptobox exception: " <> show e

integration/test/Test/MLS.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-ambiguous-fields #-}
+{-# OPTIONS_GHC -fmax-errors=10 #-}
 
 module Test.MLS where
 
@@ -159,6 +160,7 @@ testMixedProtocolNonTeam secondDomain = do
   bindResponse (putConversationProtocol bob convId "mixed") $ \resp -> do
     resp.status `shouldMatchInt` 403
 
+-- TODO: This test could fail because of not keeping track of protocol
 testMixedProtocolAddUsers :: (HasCallStack) => Domain -> Ciphersuite -> App ()
 testMixedProtocolAddUsers secondDomain suite = do
   (alice, tid, _) <- createTeam OwnDomain 1
@@ -197,6 +199,7 @@ testMixedProtocolAddUsers secondDomain suite = do
     (suiteCode, _) <- assertOne $ T.hexadecimal (T.pack suite.code)
     resp.json %. "cipher_suite" `shouldMatchInt` suiteCode
 
+-- TODO: This test could fail because of not keeping track of protocol
 testMixedProtocolUserLeaves :: (HasCallStack) => Domain -> App ()
 testMixedProtocolUserLeaves secondDomain = do
   (alice, tid, _) <- createTeam OwnDomain 1

integration/test/Testlib/Env.hs

@@ -22,6 +22,7 @@ import System.Exit
 import System.FilePath
 import System.IO
 import System.IO.Temp
+import Testlib.JSON
 import Testlib.Prekeys
 import Testlib.ResourcePool
 import Testlib.Types