[FS-507] Support for Remote Welcome Messages (#2368)

* Use a new internal endpoint to insert a key package ref for a remote client

Co-authored-by: Stefan Matting <[email protected]>

changelog.d/6-federation/mls-welcome

@@ -0,0 +1 @@
+Support remote welcome messages

libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs

@@ -14,12 +14,13 @@
 --
 -- 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/>.
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Wire.API.Federation.API.Galley where
 
 import Data.Aeson (FromJSON, ToJSON)
-import Data.Id (ClientId, ConvId, UserId)
-import Data.Json.Util (Base64ByteString)
+import Data.Id
+import Data.Json.Util
 import Data.Misc (Milliseconds)
 import Data.Qualified
 import Data.Range
@@ -59,6 +60,7 @@ type GalleyApi =
     :<|> FedEndpoint "send-message" MessageSendRequest MessageSendResponse
     :<|> FedEndpoint "on-user-deleted-conversations" UserDeletedConversationsNotification EmptyResponse
     :<|> FedEndpoint "update-conversation" ConversationUpdateRequest ConversationUpdateResponse
+    :<|> FedEndpoint "mls-welcome" MLSWelcomeRequest ()
 
 data GetConversationsRequest = GetConversationsRequest
   { gcrUserId :: UserId,
@@ -253,3 +255,18 @@ data ConversationUpdateResponse
   deriving
     (ToJSON, FromJSON)
     via (CustomEncoded ConversationUpdateResponse)
+
+newtype MLSWelcomeRecipient = MLSWelcomeRecipient {unMLSWelRecipient :: (UserId, ClientId)}
+  deriving stock (Generic)
+  deriving (Arbitrary) via (GenericUniform MLSWelcomeRecipient)
+  deriving (FromJSON, ToJSON) via CustomEncoded MLSWelcomeRecipient
+  deriving newtype (Show, Eq)
+
+data MLSWelcomeRequest = MLSWelcomeRequest
+  { mwrRawWelcome :: Base64ByteString,
+    -- | These are qualified implicitly by the target domain
+    mwrRecipients :: [MLSWelcomeRecipient]
+  }
+  deriving stock (Generic)
+  deriving (Arbitrary) via (GenericUniform MLSWelcomeRequest)
+  deriving (FromJSON, ToJSON) via (CustomEncoded MLSWelcomeRequest)

libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs

@@ -144,7 +144,7 @@ type AccountAPI =
         :> MultiVerb 'POST '[Servant.JSON] RegisterInternalResponses (Either RegisterError SelfProfile)
     )
 
-type MLSAPI = GetClientByKeyPackageRef :<|> GetMLSClients
+type MLSAPI = GetClientByKeyPackageRef :<|> GetMLSClients :<|> MapKeyPackageRefs
 
 type GetClientByKeyPackageRef =
   Summary "Resolve an MLS key package ref to a qualified client ID"
@@ -171,6 +171,13 @@ type GetMLSClients =
          '[Servant.JSON]
          (Respond 200 "MLS clients" (Set ClientId))
 
+type MapKeyPackageRefs =
+  Summary "Insert bundle into the KeyPackage ref mapping. Only for tests."
+    :> "mls"
+    :> "key-package-refs"
+    :> ReqBody '[Servant.JSON] KeyPackageBundle
+    :> MultiVerb 'PUT '[Servant.JSON] '[RespondEmpty 204 "Mapping was updated"] ()
+
 type GetVerificationCode =
   Summary "Get verification code for a given email and action"
     :> "users"

services/brig/src/Brig/API/Internal.hs

@@ -108,7 +108,7 @@ ejpdAPI =
     :<|> getConnectionsStatus
 
 mlsAPI :: ServerT BrigIRoutes.MLSAPI (Handler r)
-mlsAPI = getClientByKeyPackageRef :<|> getMLSClients
+mlsAPI = getClientByKeyPackageRef :<|> getMLSClients :<|> mapKeyPackageRefsInternal
 
 accountAPI :: ServerT BrigIRoutes.AccountAPI (Handler r)
 accountAPI = Named @"createUserNoVerify" createUserNoVerify
@@ -148,6 +148,12 @@ getMLSClients qusr ss = do
     getKey :: MonadClient m => ClientId -> m (ClientId, Maybe LByteString)
     getKey cid = (cid,) <$> Data.lookupMLSPublicKey (qUnqualified qusr) cid ss
 
+mapKeyPackageRefsInternal :: KeyPackageBundle -> Handler r ()
+mapKeyPackageRefsInternal bundle = do
+  wrapClientE $
+    for_ (kpbEntries bundle) $ \e ->
+      Data.mapKeyPackageRef (kpbeRef e) (kpbeUser e) (kpbeClient e)
+
 getVerificationCode :: UserId -> VerificationAction -> (Handler r) (Maybe Code.Value)
 getVerificationCode uid action = do
   user <- wrapClientE $ Api.lookupUser NoPendingInvitations uid

services/galley/src/Galley/API/Federation.hs

@@ -14,6 +14,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/>.
+{-# LANGUAGE OverloadedStrings #-}
 
 module Galley.API.Federation where
 
@@ -22,8 +23,8 @@ import Control.Lens (itraversed, (<.>))
 import Data.ByteString.Conversion (toByteString')
 import Data.Containers.ListUtils (nubOrd)
 import Data.Domain (Domain)
-import Data.Id (ConvId, UserId)
-import Data.Json.Util (Base64ByteString (..))
+import Data.Id
+import Data.Json.Util
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map as Map
 import Data.Map.Lens (toMapOf)
@@ -37,6 +38,7 @@ import Galley.API.Action
 import Galley.API.Error
 import qualified Galley.API.Mapping as Mapping
 import Galley.API.Message
+import Galley.API.Push
 import Galley.API.Util
 import Galley.App
 import qualified Galley.Data.Conversation as Data
@@ -88,6 +90,7 @@ federationSitemap =
     :<|> Named @"send-message" sendMessage
     :<|> Named @"on-user-deleted-conversations" onUserDeleted
     :<|> Named @"update-conversation" updateConversation
+    :<|> Named @"mls-welcome" mlsSendWelcome
 
 onConversationCreated ::
   Members
@@ -523,3 +526,29 @@ instance
       runError act >>= \case
         Left _ -> throw (demote @err)
         Right res -> pure res
+
+mlsSendWelcome ::
+  Members
+    '[ GundeckAccess,
+       Input (Local ()),
+       Input UTCTime
+     ]
+    r =>
+  Domain ->
+  F.MLSWelcomeRequest ->
+  Sem r ()
+mlsSendWelcome _origDomain (F.MLSWelcomeRequest b64RawWelcome rcpts) = do
+  loc <- input @(Local ())
+  now <- input @UTCTime
+  let rawWelcome = fromBase64ByteString b64RawWelcome
+  void $
+    runMessagePush loc Nothing $
+      foldMap (uncurry $ mkPush rawWelcome loc now) (F.unMLSWelRecipient <$> rcpts)
+  where
+    mkPush :: ByteString -> Local x -> UTCTime -> UserId -> ClientId -> MessagePush 'Broadcast
+    mkPush rawWelcome l time u c =
+      -- FUTUREWORK: use the conversation ID stored in the key package mapping table
+      let lcnv = qualifyAs l (Data.selfConv u)
+          lusr = qualifyAs l u
+          e = Event (qUntagged lcnv) (qUntagged lusr) time $ EdMLSWelcome rawWelcome
+       in newMessagePush l () Nothing defMessageMetadata (u, c) e

services/galley/src/Galley/API/MLS/Welcome.hs

@@ -19,26 +19,31 @@ module Galley.API.MLS.Welcome (postMLSWelcome) where
 
 import Control.Comonad
 import Data.Id
+import Data.Json.Util
 import Data.Qualified
 import Data.Time
 import Galley.API.MLS.KeyPackage
 import Galley.API.Push
 import Galley.Data.Conversation
 import Galley.Effects.BrigAccess
+import Galley.Effects.FederatorAccess
 import Galley.Effects.GundeckAccess
 import Imports
 import Polysemy
 import Polysemy.Input
 import Wire.API.Error
 import Wire.API.Error.Galley
 import Wire.API.Event.Conversation
+import Wire.API.Federation.API
+import Wire.API.Federation.API.Galley
 import Wire.API.MLS.Credential
 import Wire.API.MLS.Serialisation
 import Wire.API.MLS.Welcome
 
 postMLSWelcome ::
   Members
     '[ BrigAccess,
+       FederatorAccess,
        GundeckAccess,
        ErrorS 'MLSKeyPackageRefNotFound,
        Input UTCTime
@@ -70,7 +75,8 @@ welcomeRecipients =
 
 sendWelcomes ::
   Members
-    '[ GundeckAccess,
+    '[ FederatorAccess,
+       GundeckAccess,
        Input UTCTime
      ]
     r =>
@@ -102,5 +108,16 @@ sendLocalWelcomes con now rawWelcome lclients = do
           e = Event (qUntagged lcnv) (qUntagged lusr) now $ EdMLSWelcome rawWelcome
        in newMessagePush lclients () (Just con) defMessageMetadata (u, c) e
 
-sendRemoteWelcomes :: ByteString -> Remote [(UserId, ClientId)] -> Sem r ()
-sendRemoteWelcomes = undefined
+sendRemoteWelcomes ::
+  Members '[FederatorAccess] r =>
+  ByteString ->
+  Remote [(UserId, ClientId)] ->
+  Sem r ()
+sendRemoteWelcomes rawWelcome rClients = do
+  let req =
+        MLSWelcomeRequest
+          { mwrRawWelcome = Base64ByteString rawWelcome,
+            mwrRecipients = MLSWelcomeRecipient <$> tUnqualified rClients
+          }
+      rpc = fedClient @'Galley @"mls-welcome" req
+  void $ runFederated rClients rpc

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

@@ -1,21 +1,3 @@
--- This file is part of the Wire Server implementation.
---
--- Copyright (C) 2020 Wire Swiss GmbH <[email protected]>
---
--- This program is free software: you can redistribute it and/or modify it under
--- the terms of the GNU Affero General Public License as published by the Free
--- Software Foundation, either version 3 of the License, or (at your option) any
--- later version.
---
--- This program is distributed in the hope that it will be useful, but WITHOUT
--- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
--- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
--- details.
---
--- 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 #-}
-
 -- This file is part of the Wire Server implementation.
 --
 -- Copyright (C) 2022 Wire Swiss GmbH <[email protected]>
@@ -32,9 +14,12 @@
 --
 -- 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/>.
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 module API.Federation where
 
+import API.MLS.Util
 import API.Util
 import Bilge
 import Bilge.Assert
@@ -43,10 +28,11 @@ 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 (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
@@ -106,7 +92,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 +1145,29 @@ 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 = 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
+    runFedClient @"mls-welcome" fedGalleyClient aliceDomain $
+      MLSWelcomeRequest
+        (Base64ByteString 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