Refactor MLS test framework (#2678)

* Implement most of the new MLS test framework

* Automatically keep track of clients in the group

* Assert that add proposal is forwarded

* Remove dead code

* Keep track of clients in the test state

* Port more external proposal tests to new framework

* Refactor test testSenderNotInConversation

- Also add a utility for creating an application message

* Port welcome tests to new MLS test framework

* Refactor test testSendAnotherUsersCommit

* Port some commit tests to new MLS test framework

* Port more commit tests

* Refactor test testAppMessage

* Refactor test testRemoteAppMessage

* Port more commit tests

* Fix bracket in testAppMessage

* Finish porting commit tests

* Refactor test testAppMessage2

* Port proposal tests

* Refactor test testLocalToRemote

* Refactor test testLocalToRemoteNonMember

* Refactor test testRemoteToLocal

* Refactor test testRemoteNonMemberToLocal

* Refactor test testRemoteToLocalWrongConversation

* Refactor test testAddUsersDirectly

* Refactor test testRemoveUsersDirectly

* Refactor test testProteusMessage

* Refactor test testAddUsersToProteus

* Generalise return type of awaitMatch and friends

Fix error reporting in assertNoEvent

* Port backend removal test

* Port final test in API/MLS

* Move MLS tests out of the Federation module

* Remove old MLS test framework

* Add CHANGELOG entry

* Fix a test setup in runMLSTest

* Update mls-test-cli

Co-authored-by: Paolo Capriotti <[email protected]>
Co-authored-by: Marko Dimjašević <[email protected]>

Author: 3 people

changelog.d/5-internal/mls-refactor-tests

@@ -0,0 +1 @@
+Refactor MLS test framework

libs/tasty-cannon/src/Test/Tasty/Cannon.hs

@@ -288,18 +288,18 @@ awaitMatch ::
   (HasCallStack, MonadIO m, MonadCatch m) =>
   Timeout ->
   WebSocket ->
-  (Notification -> Assertion) ->
-  m (Either MatchTimeout Notification)
+  (Notification -> IO a) ->
+  m (Either MatchTimeout a)
 awaitMatch t ws match = go [] []
   where
     go buf errs = do
       mn <- await t ws
       case mn of
         Just n ->
           do
-            liftIO (match n)
+            a <- liftIO (match n)
             refill buf
-            pure (Right n)
+            pure (Right a)
             `catchAll` \e -> case asyncExceptionFromException e of
               Just x -> throwM (x :: SomeAsyncException)
               Nothing ->
@@ -322,56 +322,56 @@ assertMatch ::
   (HasCallStack, MonadIO m, MonadCatch m) =>
   Timeout ->
   WebSocket ->
-  (Notification -> Assertion) ->
-  m Notification
+  (Notification -> IO a) ->
+  m a
 assertMatch t ws f = awaitMatch t ws f >>= assertSuccess
 
 assertMatch_ ::
   (HasCallStack, MonadIO m, MonadCatch m) =>
   Timeout ->
   WebSocket ->
-  (Notification -> Assertion) ->
+  (Notification -> IO a) ->
   m ()
 assertMatch_ t w = void . assertMatch t w
 
 awaitMatchN ::
   (HasCallStack, MonadIO m) =>
   Timeout ->
   [WebSocket] ->
-  (Notification -> Assertion) ->
-  m [Either MatchTimeout Notification]
+  (Notification -> IO a) ->
+  m [Either MatchTimeout a]
 awaitMatchN t wss f = snd <$$> awaitMatchN' t (((),) <$> wss) f
 
 awaitMatchN' ::
   (HasCallStack, MonadIO m) =>
   Timeout ->
   [(extra, WebSocket)] ->
-  (Notification -> Assertion) ->
-  m [(extra, Either MatchTimeout Notification)]
+  (Notification -> IO a) ->
+  m [(extra, Either MatchTimeout a)]
 awaitMatchN' t wss f = liftIO $ mapConcurrently (\(extra, ws) -> (extra,) <$> awaitMatch t ws f) wss
 
 assertMatchN ::
   (HasCallStack, MonadIO m, MonadThrow m) =>
   Timeout ->
   [WebSocket] ->
-  (Notification -> Assertion) ->
-  m [Notification]
+  (Notification -> IO a) ->
+  m [a]
 assertMatchN t wss f = awaitMatchN t wss f >>= mapM assertSuccess
 
 assertMatchN_ ::
   (HasCallStack, MonadIO m, MonadThrow m) =>
   Timeout ->
   [WebSocket] ->
-  (Notification -> Assertion) ->
+  (Notification -> IO a) ->
   m ()
 assertMatchN_ t wss f = void $ assertMatchN t wss f
 
-assertSuccess :: (HasCallStack, MonadIO m, MonadThrow m) => Either MatchTimeout Notification -> m Notification
+assertSuccess :: (HasCallStack, MonadIO m, MonadThrow m) => Either MatchTimeout a -> m a
 assertSuccess = either throwM pure
 
 assertNoEvent :: (HasCallStack, MonadIO m, MonadCatch m) => Timeout -> [WebSocket] -> m ()
 assertNoEvent t ww = do
-  results <- awaitMatchN' t (zip [(0 :: Int) ..] ww) (const $ pure ())
+  results <- awaitMatchN' t (zip [(0 :: Int) ..] ww) pure
   for_ results $ \(ix, result) ->
     either (const $ pure ()) (liftIO . f ix) result
   where

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

@@ -139,12 +139,15 @@ data ClientIdentity = ClientIdentity
     ciUser :: UserId,
     ciClient :: ClientId
   }
-  deriving stock (Eq, Show, Generic)
+  deriving stock (Eq, Ord, Show, Generic)
   deriving (FromJSON, ToJSON, S.ToSchema) via Schema ClientIdentity
 
 cidQualifiedClient :: ClientIdentity -> Qualified (UserId, ClientId)
 cidQualifiedClient cid = Qualified (ciUser cid, ciClient cid) (ciDomain cid)
 
+cidQualifiedUser :: ClientIdentity -> Qualified UserId
+cidQualifiedUser = fmap fst . cidQualifiedClient
+
 instance ToSchema ClientIdentity where
   schema =
     object "ClientIdentity" $

nix/pkgs/mls_test_cli/default.nix

@@ -15,8 +15,8 @@ rustPlatform.buildRustPackage rec {
   src = fetchFromGitHub {
     owner = "wireapp";
     repo = "mls-test-cli";
-    sha256 = "sha256-nBtXkxGstSqBEhzjcRd0RG2hv0WFgTqy1z29W2sf27U=";
-    rev = "560186482d201fe0f6194d620dba2b623fdd7f6f";
+    sha256 = "sha256-Gw1+b7kslc/KcB+pEqP1FuE6tAPqKtB6hlkLcXMuCcM=";
+    rev = "f44dec2705e1833b654cb6f02271e11a6c2fdeb0";
   };
   doCheck = false;
   cargoSha256 = "sha256-3zUGEowQREPKsfpH2y9C7BeeTTF3zat4Qfpw74fOCHQ=";

services/brig/test/integration/Util.hs

@@ -317,7 +317,7 @@ getPhoneLoginCode brig p = do
   let lbs = fromMaybe "" $ responseBody r
   pure (LoginCode <$> (lbs ^? key "code" . _String))
 
-assertUpdateNotification :: WS.WebSocket -> UserId -> UserUpdate -> IO Notification
+assertUpdateNotification :: WS.WebSocket -> UserId -> UserUpdate -> IO ()
 assertUpdateNotification ws uid upd = WS.assertMatch (5 # Second) ws $ \n -> do
   let j = Object $ List1.head (ntfPayload n)
   j ^? key "type" . _String @?= Just "user.update"

services/galley/galley.cabal

@@ -442,6 +442,7 @@ executable galley-integration
     , currency-codes
     , data-default
     , data-timeout
+    , directory
     , errors
     , exceptions
     , extended
@@ -451,6 +452,7 @@ executable galley-integration
     , galley
     , galley-types
     , gundeck-types
+    , hex
     , HsOpenSSL
     , HsOpenSSL-x509-system
     , hspec
@@ -500,6 +502,7 @@ executable galley-integration
     , transformers
     , types-common
     , types-common-journal
+    , unix
     , unliftio
     , unordered-containers
     , uri-bytestring

services/galley/test/integration/API/Federation.hs

@@ -19,15 +19,13 @@
 
 module API.Federation where
 
-import API.MLS.Util
 import API.Util
 import Bilge hiding (head)
 import Bilge.Assert
 import Control.Lens hiding ((#))
 import Data.Aeson (ToJSON (..))
 import qualified Data.Aeson as A
 import Data.ByteString.Conversion (toByteString')
-import Data.Default
 import Data.Domain
 import Data.Id (ConvId, Id (..), UserId, newClientId, randomId)
 import Data.Json.Util hiding ((#))
@@ -90,9 +88,7 @@ tests s =
       test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent,
       test s "POST /federation/send-message : Post a message sent from another backend" sendMessage,
       test s "POST /federation/on-user-deleted-conversations : Remove deleted remote user from local conversations" onUserDeleted,
-      test s "POST /federation/update-conversation : Update local conversation by a remote admin " updateConversationByRemoteAdmin,
-      test s "POST /federation/mls-welcome : Post an MLS welcome message received from another backend" sendMLSWelcome,
-      test s "POST /federation/mls-welcome : Post an MLS welcome message (key package ref not found)" sendMLSWelcomeKeyPackageNotFound
+      test s "POST /federation/update-conversation : Update local conversation by a remote admin " updateConversationByRemoteAdmin
     ]
 
 getConversationsAllFound :: TestM ()
@@ -1134,55 +1130,6 @@ updateConversationByRemoteAdmin = do
       let convUpdate :: ConversationUpdate = fromRight (error $ "Could not parse ConversationUpdate from " <> show (frBody rpc)) $ A.eitherDecode (frBody rpc)
       pure (rpc, convUpdate)
 
-sendMLSWelcome :: TestM ()
-sendMLSWelcome = do
-  let aliceDomain = Domain "a.far-away.example.com"
-  -- Alice is from the originating domain and Bob is local, i.e., on the receiving domain
-  MessagingSetup {..} <- aliceInvitesBob (1, LocalUser) def {creatorOrigin = RemoteUser aliceDomain}
-  let bob = head users
-
-  fedGalleyClient <- view tsFedGalleyClient
-  cannon <- view tsCannon
-
-  WS.bracketR cannon (qUnqualified (pUserId bob)) $ \wsB -> do
-    -- send welcome message
-    void $
-      runFedClient @"mls-welcome" fedGalleyClient aliceDomain $
-        MLSWelcomeRequest
-          (Base64ByteString welcome)
-
-    -- check that the corresponding event is received
-    liftIO $ do
-      WS.assertMatch_ (5 # WS.Second) wsB $
-        wsAssertMLSWelcome (pUserId bob) welcome
-
-sendMLSWelcomeKeyPackageNotFound :: TestM ()
-sendMLSWelcomeKeyPackageNotFound = do
-  let aliceDomain = Domain "a.far-away.example.com"
-  -- Alice is from the originating domain and Bob is local, i.e., on the receiving domain
-  MessagingSetup {..} <-
-    aliceInvitesBob
-      (1, LocalUser)
-      def
-        { creatorOrigin = RemoteUser aliceDomain,
-          createClients = DontCreateClients -- no key package upload will happen
-        }
-  let bob = head users
-
-  fedGalleyClient <- view tsFedGalleyClient
-  cannon <- view tsCannon
-
-  WS.bracketR cannon (qUnqualified (pUserId bob)) $ \wsB -> do
-    -- send welcome message
-    void $
-      runFedClient @"mls-welcome" fedGalleyClient aliceDomain $
-        MLSWelcomeRequest
-          (Base64ByteString welcome)
-
-    liftIO $ do
-      -- check that no event is received
-      WS.assertNoEvent (1 # Second) [wsB]
-
 getConvAction :: Sing tag -> SomeConversationAction -> Maybe (ConversationAction tag)
 getConvAction tquery (SomeConversationAction tag action) =
   case (tag, tquery) of