[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/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 MLSWelcomeResponse
 
 data GetConversationsRequest = GetConversationsRequest
   { gcrUserId :: UserId,
@@ -256,17 +255,23 @@ 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)
+
+data MLSWelcomeResponseError
+  = MLSWelcomeResponseErrorRefNotFound
+  | MLSWelcomeResponseErrorDecodingFailed Text
+  deriving stock (Eq, Generic, Show)
+  deriving (Arbitrary) via GenericUniform MLSWelcomeResponseError
+  deriving (FromJSON, ToJSON) via CustomEncoded MLSWelcomeResponseError
+
+newtype MLSWelcomeResponse = MLSWelcomeResponse
+  {unMLSWelcomeResponse :: Either MLSWelcomeResponseError ()}
+  deriving stock (Eq, Generic, Show)
+  deriving (Arbitrary) via GenericUniform MLSWelcomeResponse
+  deriving (FromJSON, ToJSON) via CustomEncoded MLSWelcomeResponse

libs/wire-api/src/Wire/API/Routes/Public/Galley.hs

@@ -1276,6 +1276,7 @@ type MLSMessagingAPI =
     "mls-welcome-message"
     ( Summary "Post an MLS welcome message"
         :> CanThrow 'MLSKeyPackageRefNotFound
+        :> CanThrow 'MLSProtocolErrorTag
         :> "welcome"
         :> ZConn
         :> ReqBody '[MLS] (RawMLS Welcome)

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

@@ -19,10 +19,12 @@
 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)
 import Data.Domain (Domain)
+import Data.Either.Combinators
 import Data.Id
 import Data.Json.Util
 import Data.List.NonEmpty (NonEmpty (..))
@@ -32,10 +34,12 @@ 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.Welcome
 import qualified Galley.API.Mapping as Mapping
 import Galley.API.Message
 import Galley.API.Push
@@ -72,6 +76,7 @@ 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.Serialisation
 import Wire.API.Routes.Internal.Brig.Connection
 import Wire.API.Routes.Named
 import Wire.API.ServantProto
@@ -290,7 +295,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 +304,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 +533,58 @@ instance
 
 mlsSendWelcome ::
   Members
-    '[ GundeckAccess,
+    '[ BrigAccess,
+       GundeckAccess,
        Input (Local ()),
        Input UTCTime
      ]
     r =>
   Domain ->
   F.MLSWelcomeRequest ->
-  Sem r ()
-mlsSendWelcome _origDomain (F.MLSWelcomeRequest b64RawWelcome rcpts) = do
+  Sem r F.MLSWelcomeResponse
+mlsSendWelcome _origDomain (F.unMLSWelcomeRequest -> welBase64) = do
   loc <- input @(Local ())
   now <- input @UTCTime
-  let rawWelcome = fromBase64ByteString b64RawWelcome
-  void $
-    runMessagePush loc Nothing $
-      foldMap (uncurry $ mkPush rawWelcome loc now) (F.unMLSWelRecipient <$> rcpts)
+  let rawWelcome = fromBase64ByteString welBase64
+  runErrors $ do
+    welcome <-
+      fromEither
+        . mapLeft (const . mlsProtocolError $ decodingErrorMsg)
+        . decodeMLS'
+        $ rawWelcome
+    -- Extract only recipients local to this backend
+    rcpts <-
+      fmap fold $
+        foldQualified loc ((: []) . tUnqualified) (const mempty)
+          <$$> welcomeRecipients welcome
+    void $
+      runMessagePush loc Nothing $
+        foldMap (uncurry $ mkPush rawWelcome loc now) rcpts
   where
+    decodingErrorMsg = "Could not decode the welcome message"
     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
+
+    runErrors ::
+      Sem (Error MLSProtocolError ': ErrorS 'MLSKeyPackageRefNotFound ': r) () ->
+      Sem r F.MLSWelcomeResponse
+    runErrors = fmap F.MLSWelcomeResponse . runDerefError . runProtocolError
+
+    runProtocolError ::
+      Sem (Error MLSProtocolError ': r) () ->
+      Sem r (Either F.MLSWelcomeResponseError ())
+    runProtocolError =
+      fmap (mapLeft (\(Tagged msg) -> F.MLSWelcomeResponseErrorDecodingFailed msg))
+        . runError
+
+    runDerefError ::
+      Sem (ErrorS 'MLSKeyPackageRefNotFound ': r) (Either F.MLSWelcomeResponseError ()) ->
+      Sem r (Either F.MLSWelcomeResponseError ())
+    runDerefError =
+      fmap (join . mapLeft (const F.MLSWelcomeResponseErrorRefNotFound))
+        . runError

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,
+    welcomeRecipients,
+  )
+where
 
 import Control.Comonad
+import Data.Either.Combinators
 import Data.Id
 import Data.Json.Util
 import Data.Qualified
@@ -30,6 +35,7 @@ import Galley.Effects.FederatorAccess
 import Galley.Effects.GundeckAccess
 import Imports
 import Polysemy
+import Polysemy.Error
 import Polysemy.Input
 import Wire.API.Error
 import Wire.API.Error.Galley
@@ -45,6 +51,7 @@ postMLSWelcome ::
     '[ BrigAccess,
        FederatorAccess,
        GundeckAccess,
+       Error MLSProtocolError,
        ErrorS 'MLSKeyPackageRefNotFound,
        Input UTCTime
      ]
@@ -75,7 +82,9 @@ welcomeRecipients =
 
 sendWelcomes ::
   Members
-    '[ FederatorAccess,
+    '[ Error MLSProtocolError,
+       ErrorS 'MLSKeyPackageRefNotFound,
+       FederatorAccess,
        GundeckAccess,
        Input UTCTime
      ]
@@ -109,15 +118,19 @@ sendLocalWelcomes con now rawWelcome lclients = do
        in newMessagePush lclients () (Just con) defMessageMetadata (u, c) e
 
 sendRemoteWelcomes ::
-  Members '[FederatorAccess] r =>
+  Members
+    '[ Error MLSProtocolError,
+       ErrorS 'MLSKeyPackageRefNotFound,
+       FederatorAccess
+     ]
+    r =>
   ByteString ->
   Remote [(UserId, ClientId)] ->
   Sem r ()
 sendRemoteWelcomes rawWelcome rClients = do
-  let req =
-        MLSWelcomeRequest
-          { mwrRawWelcome = Base64ByteString rawWelcome,
-            mwrRecipients = MLSWelcomeRecipient <$> tUnqualified rClients
-          }
+  let req = MLSWelcomeRequest . Base64ByteString $ rawWelcome
       rpc = fedClient @'Galley @"mls-welcome" req
-  void $ runFederated rClients rpc
+  resp <- unMLSWelcomeResponse <$> runFederated rClients rpc
+  whenLeft resp $ \case
+    MLSWelcomeResponseErrorRefNotFound -> throwS @'MLSKeyPackageRefNotFound
+    MLSWelcomeResponseErrorDecodingFailed msg -> throw . mlsProtocolError $ msg

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

@@ -32,7 +32,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
@@ -93,7 +93,9 @@ 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,
+      test s "POST /federation/mls-welcome : Post an MLS welcome message (MLS decoding failed)" sendMLSWelcomeDecodingFailed
     ]
 
 getConversationsAllFound :: TestM ()
@@ -1151,22 +1153,74 @@ 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
+  void . WS.bracketR cannon (qUnqualified (pUserId bob)) $ \wsB -> do
     -- send welcome message
-    runFedClient @"mls-welcome" fedGalleyClient aliceDomain $
-      MLSWelcomeRequest
-        (Base64ByteString welcome)
-        [MLSWelcomeRecipient (qUnqualified . pUserId $ bob, bobClient)]
+    MLSWelcomeResponse resp <-
+      runFedClient @"mls-welcome" fedGalleyClient aliceDomain $
+        MLSWelcomeRequest
+          (Base64ByteString welcome)
 
     -- check that the corresponding event is received
-    void . liftIO $
-      WS.assertMatch (5 # WS.Second) wsB $
+    void . liftIO $ do
+      void . WS.assertMatch (5 # WS.Second) wsB $
         wsAssertMLSWelcome (pUserId bob) welcome
+      resp @?= Right ()
+
+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
+
+  void . WS.bracketR cannon (qUnqualified (pUserId bob)) $ \wsB -> do
+    -- send welcome message
+    MLSWelcomeResponse resp <-
+      runFedClient @"mls-welcome" fedGalleyClient aliceDomain $
+        MLSWelcomeRequest
+          (Base64ByteString welcome)
+
+    -- check that no event is received
+    void . liftIO $ do
+      WS.assertNoEvent (1 # Second) [wsB]
+      resp @?= Left MLSWelcomeResponseErrorRefNotFound
+
+sendMLSWelcomeDecodingFailed :: TestM ()
+sendMLSWelcomeDecodingFailed = do
+  let aliceDomain = Domain "a.far-away.example.com"
+  bob <- randomQualifiedUser
+
+  fedGalleyClient <- view tsFedGalleyClient
+  cannon <- view tsCannon
+
+  void . WS.bracketR cannon (qUnqualified bob) $ \wsB -> do
+    -- send a gibberish welcome message
+    MLSWelcomeResponse resp <-
+      runFedClient @"mls-welcome" fedGalleyClient aliceDomain $
+        MLSWelcomeRequest
+          (Base64ByteString "gibberish")
+
+    -- check that no event is received
+    void . liftIO $ do
+      WS.assertNoEvent (1 # Second) [wsB]
+      resp
+        @?= Left
+          ( MLSWelcomeResponseErrorDecodingFailed
+              "Could not decode the welcome message"
+          )
 
 getConvAction :: Sing tag -> SomeConversationAction -> Maybe (ConversationAction tag)
 getConvAction tquery (SomeConversationAction tag action) =

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

@@ -28,6 +28,7 @@ import qualified Data.Aeson as Aeson
 import Data.Default
 import Data.Domain
 import Data.Id
+import Data.Json.Util hiding ((#))
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.List1
 import Data.Qualified
@@ -142,11 +143,11 @@ testRemoteWelcome = do
       opts = def {createConv = CreateConv, createClients = DontCreateClients}
   MessagingSetup {..} <- aliceInvitesBob (1, RemoteUser bobDomain) opts
   let alice = creator
-      bob = Imports.head users
 
+  let okResp = MLSWelcomeResponse . Right $ ()
   let mockedResponse fedReq =
         case frRPC fedReq of
-          "mls-welcome" -> pure (Aeson.encode ())
+          "mls-welcome" -> pure (Aeson.encode okResp)
           ms -> assertFailure ("unmocked endpoint called: " <> cs ms)
 
   (_resp, reqs) <-
@@ -156,15 +157,8 @@ testRemoteWelcome = do
 
   --  Assert the correct federated call is made.
   fedWelcome <- assertOne (filter ((== "mls-welcome") . frRPC) reqs)
-  let welcomeRequest :: Maybe MLSWelcomeRequest = Aeson.decode (frBody fedWelcome)
-  liftIO $
-    fmap mwrRecipients welcomeRequest
-      @?= Just
-        [ MLSWelcomeRecipient
-            ( qUnqualified . pUserId $ bob,
-              snd . NonEmpty.head . pClients $ bob
-            )
-        ]
+  let req :: Maybe MLSWelcomeRequest = Aeson.decode (frBody fedWelcome)
+  liftIO $ req @?= (Just . MLSWelcomeRequest . Base64ByteString) welcome
 
 -- | Send a commit message, and assert that all participants see an event with
 -- the given list of new members.