diff --git a/changelog.d/6-federation/fix-fed-welcome-request b/changelog.d/6-federation/fix-fed-welcome-request
new file mode 100644
index 0000000000..5ee60e16e9
--- /dev/null
+++ b/changelog.d/6-federation/fix-fed-welcome-request
@@ -0,0 +1 @@
+Send only the raw welcome message in the Galley "mls-welcome" federation endpoint
diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs
index 8ec0177ced..ed679c8780 100644
--- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs
+++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs
@@ -352,17 +352,16 @@ 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
@@ -370,6 +369,10 @@ logErrorMsg mr (Wai.Error c l m md) =
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
diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs
index 6b4ed3fd56..b26d82695c 100644
--- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs
+++ b/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 .
-{-# 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)
diff --git a/services/federator/src/Federator/Response.hs b/services/federator/src/Federator/Response.hs
index 7dac50589d..7cc670ad3d 100644
--- a/services/federator/src/Federator/Response.hs
+++ b/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 ::
diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs
index bbfd6642e8..9a3e1a55e2 100644
--- a/services/galley/src/Galley/API/Federation.hs
+++ b/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
diff --git a/services/galley/src/Galley/API/MLS/Welcome.hs b/services/galley/src/Galley/API/MLS/Welcome.hs
index b8445b62cb..65194d085c 100644
--- a/services/galley/src/Galley/API/MLS/Welcome.hs
+++ b/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 .
-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,7 +55,8 @@ postMLSWelcome ::
FederatorAccess,
GundeckAccess,
ErrorS 'MLSKeyPackageRefNotFound,
- Input UTCTime
+ Input UTCTime,
+ P.TinyLog
]
r =>
Local UserId ->
@@ -54,8 +64,11 @@ postMLSWelcome ::
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))
diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs
index 0918e4acc2..6f4ec83254 100644
--- a/services/galley/test/integration/API/Federation.hs
+++ b/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
diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs
index 5cf7e4eb77..9ec030941f 100644
--- a/services/galley/test/integration/API/MLS.hs
+++ b/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
@@ -47,6 +48,7 @@ import TestHelpers
import TestSetup
import Wire.API.Conversation
import Wire.API.Conversation.Role
+import Wire.API.Federation.API.Common
import Wire.API.Federation.API.Galley
import Wire.API.Message
@@ -142,11 +144,11 @@ testRemoteWelcome = do
opts = def {createConv = CreateConv, createClients = DontCreateClients}
MessagingSetup {..} <- aliceInvitesBob (1, RemoteUser bobDomain) opts
let alice = creator
- bob = Imports.head users
+ let okResp = EmptyResponse
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 +158,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.