Implement a test for the server side of POST /federation/mls-welcome

Author: mdimjasevic

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

@@ -15,6 +15,7 @@
 -- 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/>.
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE RecordWildCards #-}
 
 -- This file is part of the Wire Server implementation.
 --
@@ -35,6 +36,7 @@
 
 module API.Federation where
 
+import API.MLS.Util
 import API.Util
 import Bilge
 import Bilge.Assert
@@ -45,8 +47,8 @@ import qualified Data.Aeson as A
 import Data.ByteString.Conversion (toByteString')
 import Data.Domain
 import Data.Id (ConvId, Id (..), UserId, newClientId, randomId)
-import Data.Json.Util (Base64ByteString (..), toBase64Text)
-import Data.List.NonEmpty (NonEmpty (..))
+import Data.Json.Util hiding ((#))
+import Data.List.NonEmpty (NonEmpty(..), head)
 import Data.List1
 import qualified Data.List1 as List1
 import qualified Data.Map as Map
@@ -81,6 +83,7 @@ import Wire.API.Internal.Notification
 import Wire.API.Message (ClientMismatchStrategy (..), MessageSendingStatus (mssDeletedClients, mssFailedToSend, mssRedundantClients), mkQualifiedOtrPayload, mssMissingClients)
 import Wire.API.User.Client (PubClient (..))
 import Wire.API.User.Profile
+import Data.Default
 
 tests :: IO TestSetup -> TestTree
 tests s =
@@ -106,7 +109,8 @@ 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/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
     ]
 
 getConversationsAllFound :: TestM ()
@@ -1158,6 +1162,31 @@ 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 def { creatorOrigin = RemoteCreator aliceDomain }
+  let bob = users !! 0
+      bobClient = snd . Data.List.NonEmpty.head . pClients $ bob
+
+  fedGalleyClient <- view tsFedGalleyClient
+  cannon <- view tsCannon
+
+  WS.bracketR cannon (qUnqualified (pUserId bob)) $ \wsB -> do
+    -- send welcome message
+    EmptyResponse <-
+      runFedClient @"mls-welcome" fedGalleyClient aliceDomain $
+        MLSWelcomeRequest
+          (toBase64ByteString welcome)
+          [MLSWelcomeRecipient (qUnqualified . pUserId $ bob, bobClient)]
+
+    -- check that the corresponding event is received
+    void . liftIO $
+      WS.assertMatch (5 # WS.Second) wsB $
+        wsAssertMLSWelcome (pUserId bob) welcome
+
+
 getConvAction :: Sing tag -> SomeConversationAction -> Maybe (ConversationAction tag)
 getConvAction tquery (SomeConversationAction tag action) =
   case (tag, tquery) of

services/galley/test/integration/API/MLS/Util.hs

@@ -58,13 +58,17 @@ data CreateClients = CreateWithoutKey | CreateWithKey | DontCreateClients
 data CreateConv = CreateConv | CreateProteusConv | DontCreateConv
   deriving (Eq)
 
+data CreatorOrigin = LocalCreator | RemoteCreator Domain
+
 createNewConv :: CreateConv -> Maybe NewConv
 createNewConv CreateConv = Just defNewMLSConv
 createNewConv CreateProteusConv = Just defNewProteusConv
 createNewConv DontCreateConv = Nothing
 
+
 data SetupOptions = SetupOptions
   { createClients :: CreateClients,
+    creatorOrigin :: CreatorOrigin,
     createConv :: CreateConv,
     makeConnections :: Bool
   }
@@ -73,6 +77,7 @@ instance Default SetupOptions where
   def =
     SetupOptions
       { createClients = CreateWithKey,
+        creatorOrigin = LocalCreator,
         createConv = DontCreateConv,
         makeConnections = True
       }
@@ -152,41 +157,31 @@ setupParticipants ::
   [Int] ->
   State.StateT [LastPrekey] TestM (Participant, [Participant])
 setupParticipants tmp SetupOptions {..} ns = do
-  creator <- lift randomQualifiedUser >>= setupParticipant tmp DontCreateClients 1
+  creator <- lift (creatorUserOrId creatorOrigin) >>= setupParticipant tmp DontCreateClients 1
   others <- for ns $ \n ->
     lift randomQualifiedUser >>= setupParticipant tmp createClients n
-  lift . when makeConnections $
-    traverse_
-      ( connectUsers (qUnqualified (pUserId creator))
-          . List1
-          . fmap (qUnqualified . pUserId)
-      )
-      (nonEmpty others)
+  lift . when makeConnections $ case creatorOrigin of
+    LocalCreator ->
+      traverse_
+        ( connectUsers (qUnqualified (pUserId creator))
+            . List1
+            . fmap (qUnqualified . pUserId)
+        )
+        (nonEmpty others)
+    RemoteCreator _ ->
+      traverse_
+        ( \u ->
+            connectWithRemoteUser
+              (qUnqualified . pUserId $ u)
+              (pUserId creator)
+        )
+        others
   pure (creator, others)
-
--- | Just like 'setupParticipants', this function sets up MLS participants. The
--- assumption is that the creator is remote to the local backend, and the rest
--- of participants are local.
-setupParticipantsOnServer ::
-  HasCallStack =>
-  FilePath ->
-  Domain ->
-  SetupOptions ->
-  [Int] ->
-  State.StateT [LastPrekey] TestM (Participant, [Participant])
-setupParticipantsOnServer tmp originDomain SetupOptions {..} ns = do
-  creator <- lift (randomQualifiedId originDomain) >>= setupParticipant tmp DontCreateClients 1
-  locals <- for ns $ \n ->
-    lift randomQualifiedUser >>= setupParticipant tmp createClients n
-  lift . when makeConnections $
-    traverse_
-      ( \u ->
-          connectWithRemoteUser
-            (qUnqualified . pUserId $ u)
-            (pUserId creator)
-      )
-      locals
-  pure (creator, locals)
+    where
+      creatorUserOrId :: CreatorOrigin -> TestM (Qualified UserId)
+      creatorUserOrId = \case
+        LocalCreator -> randomQualifiedUser
+        RemoteCreator d -> randomQualifiedId d
 
 withLastPrekeys :: Monad m => State.StateT [LastPrekey] m a -> m a
 withLastPrekeys m = State.evalStateT m someLastPrekeys
@@ -242,11 +237,12 @@ takeLastPrekey = do
   State.put lpks
   pure lpk
 
--- | Setup: Alice creates a group and invites bob. Return welcome and commit message.
+-- | Setup: Alice creates a group and invites Bob that is local or remote to
+-- Alice depending on the passed in creator origin. Return welcome and commit
+-- message.
 aliceInvitesBob :: HasCallStack => Int -> SetupOptions -> TestM MessagingSetup
 aliceInvitesBob numBobClients opts@SetupOptions {..} = withSystemTempDirectory "mls" $ \tmp -> do
   (alice, [bob]) <- withLastPrekeys $ setupParticipants tmp opts [numBobClients]
-
   -- create a group
   conversation <- setupGroup tmp createConv alice "group"