[FS-507] Improve the Federated Welcome Message Request

changelog.d/6-federation/fix-fed-welcome-request

@@ -0,0 +1 @@
+Send only the raw welcome message in the Galley "mls-welcome" federation endpoint

libs/wai-utilities/src/Network/Wai/Utilities/Server.hs

@@ -352,24 +352,27 @@ logError :: (MonadIO m, HasRequest r) => Logger -> Maybe r -> Wai.Error -> m ()
 logError g mr = logError' g (lookupRequestId =<< mr)
 
 logError' :: (MonadIO m) => Logger -> Maybe ByteString -> Wai.Error -> m ()
-logError' g mr e = liftIO $ doLog g (logErrorMsg mr e)
+logError' g mr e = liftIO $ doLog g (logErrorMsgWithRequest mr e)
   where
     doLog
       | statusCode (Error.code e) >= 500 = Log.err
       | otherwise = Log.debug
 
-logErrorMsg :: Maybe ByteString -> Wai.Error -> Msg -> Msg
-logErrorMsg mr (Wai.Error c l m md) =
+logErrorMsg :: Wai.Error -> Msg -> Msg
+logErrorMsg (Wai.Error c l m md) =
   field "code" (statusCode c)
     . field "label" l
-    . field "request" (fromMaybe "N/A" mr)
     . fromMaybe id (fmap logErrorData md)
     . msg (val "\"" +++ m +++ val "\"")
   where
     logErrorData (Wai.FederationErrorData d p) =
       field "domain" (domainText d)
         . field "path" p
 
+logErrorMsgWithRequest :: Maybe ByteString -> Wai.Error -> Msg -> Msg
+logErrorMsgWithRequest mr e =
+  field "request" (fromMaybe "N/A" mr) . logErrorMsg e
+
 logIO :: (ToBytes msg, HasRequest r) => Logger -> Level -> Maybe r -> msg -> IO ()
 logIO lg lv r a =
   let reqId = field "request" . fromMaybe "N/A" . lookupRequestId <$> r

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

@@ -14,7 +14,6 @@
 --
 -- 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
 
@@ -60,7 +59,7 @@ type GalleyApi =
     :<|> FedEndpoint "send-message" MessageSendRequest MessageSendResponse
     :<|> FedEndpoint "on-user-deleted-conversations" UserDeletedConversationsNotification EmptyResponse
     :<|> FedEndpoint "update-conversation" ConversationUpdateRequest ConversationUpdateResponse
-    :<|> FedEndpoint "mls-welcome" MLSWelcomeRequest ()
+    :<|> FedEndpoint "mls-welcome" MLSWelcomeRequest EmptyResponse
 
 data GetConversationsRequest = GetConversationsRequest
   { gcrUserId :: UserId,
@@ -256,17 +255,10 @@ data ConversationUpdateResponse
     (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]
+-- | A wrapper around a raw welcome message
+newtype MLSWelcomeRequest = MLSWelcomeRequest
+  { unMLSWelcomeRequest :: Base64ByteString
   }
-  deriving stock (Generic)
+  deriving stock (Eq, Generic, Show)
   deriving (Arbitrary) via (GenericUniform MLSWelcomeRequest)
   deriving (FromJSON, ToJSON) via (CustomEncoded MLSWelcomeRequest)

services/federator/src/Federator/Response.hs

@@ -88,7 +88,7 @@ runWaiError =
   where
     logError :: Members '[Error Wai.Error, TinyLog] r => Wai.Error -> Sem r a
     logError e = do
-      err $ Wai.logErrorMsg Nothing e
+      err $ Wai.logErrorMsg e
       throw e
 
 serve ::

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

@@ -19,6 +19,7 @@
 module Galley.API.Federation where
 
 import Brig.Types.Connection (Relation (Accepted))
+import Control.Error
 import Control.Lens (itraversed, (<.>))
 import Data.ByteString.Conversion (toByteString')
 import Data.Containers.ListUtils (nubOrd)
@@ -32,13 +33,15 @@ import Data.Qualified
 import Data.Range (Range (fromRange))
 import qualified Data.Set as Set
 import Data.Singletons (SingI (..), demote, sing)
+import Data.Tagged
 import qualified Data.Text.Lazy as LT
 import Data.Time.Clock
 import Galley.API.Action
 import Galley.API.Error
+import Galley.API.MLS.KeyPackage
+import Galley.API.MLS.Welcome
 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
@@ -72,6 +75,9 @@ import Wire.API.Federation.API.Common (EmptyResponse (..))
 import Wire.API.Federation.API.Galley (ConversationUpdateResponse)
 import qualified Wire.API.Federation.API.Galley as F
 import Wire.API.Federation.Error
+import Wire.API.MLS.Credential
+import Wire.API.MLS.Serialisation
+import Wire.API.MLS.Welcome
 import Wire.API.Routes.Internal.Brig.Connection
 import Wire.API.Routes.Named
 import Wire.API.ServantProto
@@ -290,7 +296,7 @@ leaveConversation requestingDomain lc = do
         pure (update, conv)
 
   case res of
-    Left err -> pure $ F.LeaveConversationResponse (Left err)
+    Left e -> pure $ F.LeaveConversationResponse (Left e)
     Right (_update, conv) -> do
       let action = pure (qUntagged leaver)
 
@@ -299,7 +305,6 @@ leaveConversation requestingDomain lc = do
       _event <- notifyConversationAction SConversationLeaveTag (qUntagged leaver) Nothing lcnv botsAndMembers action
 
       pure $ F.LeaveConversationResponse (Right ())
-  where
 
 -- FUTUREWORK: report errors to the originating backend
 -- FUTUREWORK: error handling for missing / mismatched clients
@@ -529,26 +534,32 @@ instance
 
 mlsSendWelcome ::
   Members
-    '[ GundeckAccess,
+    '[ BrigAccess,
+       Error InternalError,
+       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
+  Sem r EmptyResponse
+mlsSendWelcome _origDomain (fromBase64ByteString . F.unMLSWelcomeRequest -> rawWelcome) = do
+  loc <- qualifyLocal ()
+  now <- input
+  welcome <- either (throw . InternalErrorWithDescription . LT.fromStrict) pure $ decodeMLS' rawWelcome
+  -- Extract only recipients local to this backend
+  rcpts <-
+    fmap catMaybes $
+      traverse
+        ( fmap (fmap cidQualifiedClient . hush)
+            . runError @(Tagged 'MLSKeyPackageRefNotFound ())
+            . derefKeyPackage
+            . gsNewMember
+        )
+        $ welSecrets welcome
+  let lrcpts = qualifyAs loc $ fst $ partitionQualified loc rcpts
+
+  sendLocalWelcomes Nothing now rawWelcome lrcpts
+
+  pure EmptyResponse

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

@@ -15,9 +15,14 @@
 -- 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 Galley.API.MLS.Welcome (postMLSWelcome) where
+module Galley.API.MLS.Welcome
+  ( postMLSWelcome,
+    sendLocalWelcomes,
+  )
+where
 
 import Control.Comonad
+import Data.Domain
 import Data.Id
 import Data.Json.Util
 import Data.Qualified
@@ -29,13 +34,17 @@ import Galley.Effects.BrigAccess
 import Galley.Effects.FederatorAccess
 import Galley.Effects.GundeckAccess
 import Imports
+import Network.Wai.Utilities.Server
 import Polysemy
 import Polysemy.Input
+import qualified Polysemy.TinyLog as P
+import qualified System.Logger.Class as Logger
 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.Federation.Error
 import Wire.API.MLS.Credential
 import Wire.API.MLS.Serialisation
 import Wire.API.MLS.Welcome
@@ -46,16 +55,20 @@ postMLSWelcome ::
        FederatorAccess,
        GundeckAccess,
        ErrorS 'MLSKeyPackageRefNotFound,
-       Input UTCTime
+       Input UTCTime,
+       P.TinyLog
      ]
     r =>
   Local UserId ->
   ConnId ->
   RawMLS Welcome ->
   Sem r ()
 postMLSWelcome lusr con wel = do
+  now <- input
   rcpts <- welcomeRecipients (rmValue wel)
-  traverse_ (sendWelcomes lusr con (rmRaw wel)) (bucketQualified rcpts)
+  let (locals, remotes) = partitionQualified lusr rcpts
+  sendLocalWelcomes (Just con) now (rmRaw wel) (qualifyAs lusr locals)
+  sendRemoteWelcomes (rmRaw wel) remotes
 
 welcomeRecipients ::
   Members
@@ -73,25 +86,9 @@ welcomeRecipients =
     )
     . welSecrets
 
-sendWelcomes ::
-  Members
-    '[ FederatorAccess,
-       GundeckAccess,
-       Input UTCTime
-     ]
-    r =>
-  Local x ->
-  ConnId ->
-  ByteString ->
-  Qualified [(UserId, ClientId)] ->
-  Sem r ()
-sendWelcomes loc con rawWelcome recipients = do
-  now <- input
-  foldQualified loc (sendLocalWelcomes con now rawWelcome) (sendRemoteWelcomes rawWelcome) recipients
-
 sendLocalWelcomes ::
   Members '[GundeckAccess] r =>
-  ConnId ->
+  Maybe ConnId ->
   UTCTime ->
   ByteString ->
   Local [(UserId, ClientId)] ->
@@ -106,18 +103,28 @@ sendLocalWelcomes con now rawWelcome lclients = do
       let lcnv = qualifyAs lclients (selfConv u)
           lusr = qualifyAs lclients u
           e = Event (qUntagged lcnv) (qUntagged lusr) now $ EdMLSWelcome rawWelcome
-       in newMessagePush lclients () (Just con) defMessageMetadata (u, c) e
+       in newMessagePush lclients () con defMessageMetadata (u, c) e
 
 sendRemoteWelcomes ::
-  Members '[FederatorAccess] r =>
+  Members
+    '[ FederatorAccess,
+       P.TinyLog
+     ]
+    r =>
   ByteString ->
-  Remote [(UserId, ClientId)] ->
+  [Remote (UserId, ClientId)] ->
   Sem r ()
-sendRemoteWelcomes rawWelcome rClients = do
-  let req =
-        MLSWelcomeRequest
-          { mwrRawWelcome = Base64ByteString rawWelcome,
-            mwrRecipients = MLSWelcomeRecipient <$> tUnqualified rClients
-          }
+sendRemoteWelcomes rawWelcome clients = do
+  let req = MLSWelcomeRequest . Base64ByteString $ rawWelcome
       rpc = fedClient @'Galley @"mls-welcome" req
-  void $ runFederated rClients rpc
+  (traverse_ handleError =<<)
+    . runFederatedConcurrentlyEither clients
+    $ \_ -> rpc
+  where
+    handleError :: Member P.TinyLog r => Either (Remote [a], FederationError) x -> Sem r ()
+    handleError (Right _) = pure ()
+    handleError (Left (r, e)) =
+      P.warn $
+        Logger.msg ("A welcome message could not be delivered to a remote backend" :: ByteString)
+          . Logger.field "remote_domain" (domainText (tDomain r))
+          . (logErrorMsg (toWai e))

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

@@ -31,7 +31,7 @@ import Data.Default
 import Data.Domain
 import Data.Id (ConvId, Id (..), UserId, newClientId, randomId)
 import Data.Json.Util hiding ((#))
-import Data.List.NonEmpty (NonEmpty (..), head)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.List1
 import qualified Data.List1 as List1
 import qualified Data.Map as Map
@@ -92,7 +92,8 @@ tests s =
       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 received from another backend" sendMLSWelcome,
+      test s "POST /federation/mls-welcome : Post an MLS welcome message (key package ref not found)" sendMLSWelcomeKeyPackageNotFound
     ]
 
 getConversationsAllFound :: TestM ()
@@ -1148,23 +1149,52 @@ sendMLSWelcome = do
   -- 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)]
+    void $
+      runFedClient @"mls-welcome" fedGalleyClient aliceDomain $
+        MLSWelcomeRequest
+          (Base64ByteString welcome)
 
     -- check that the corresponding event is received
-    void . liftIO $
-      WS.assertMatch (5 # WS.Second) wsB $
+    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 = users !! 0
+
+  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]
+
+-- success is reported, even though no client receives the welcome
+-- message due to missing key package references
+
 getConvAction :: Sing tag -> SomeConversationAction -> Maybe (ConversationAction tag)
 getConvAction tquery (SomeConversationAction tag action) =
   case (tag, tquery) of