From 7fa7f29a673ddb270f02c688f4d352c534418169 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 25 Sep 2023 13:34:07 +0200 Subject: [PATCH 1/5] Add test reproducing MLS notification bug --- integration/test/Test/MLS/Message.hs | 31 ++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/integration/test/Test/MLS/Message.hs b/integration/test/Test/MLS/Message.hs index 88dce5a28d..e2deb2fadb 100644 --- a/integration/test/Test/MLS/Message.hs +++ b/integration/test/Test/MLS/Message.hs @@ -1,5 +1,8 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + module Test.MLS.Message where +import API.Gundeck import MLS.Util import Notifications import SetupHelpers @@ -50,3 +53,31 @@ testAppMessageSomeReachable = do pure alice1 void $ createApplicationMessage alice1 "hi, bob!" >>= sendAndConsumeMessage + +testMessageNotifications :: HasCallStack => App () +testMessageNotifications = do + [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] + + [alice1, alice2, bob1, bob2] <- traverse (createMLSClient def) [alice, alice, bob, bob] + aliceClient <- alice1 %. "client_id" & asString + bobClient <- bob1 %. "client_id" & asString + + traverse_ uploadNewKeyPackage [alice1, alice2, bob1, bob2] + + void $ createNewGroup alice1 + void $ createAddCommit alice1 [alice, bob] >>= sendAndConsumeCommitBundle + + let get (opts :: GetNotifications) = do + notifs <- getNotifications bob opts {size = Just 10000} >>= getJSON 200 + notifs %. "has_more" `shouldMatch` False + length <$> (notifs %. "notifications" & asList) + + numNotifs <- get def + numNotifsClient <- get def {client = Just bobClient} + + void $ withWebSocket bob $ \ws -> do + void $ createApplicationMessage alice1 "hi bob" >>= sendAndConsumeMessage + awaitMatch 10 isNewMLSMessageNotif ws + + get def `shouldMatchInt` (numNotifs + 1) + get def {client = Just bobClient} `shouldMatchInt` (numNotifsClient + 1) From 7ecfbe786d0f9ff026a980c7149d7376657aecf1 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 25 Sep 2023 16:01:40 +0200 Subject: [PATCH 2/5] Collect recipients by user before pushing notif --- .../src/Gundeck/Types/Push/V2.hs | 6 +++++ .../galley/src/Galley/API/MLS/Propagate.hs | 17 ++++++++----- services/galley/src/Galley/API/Push.hs | 24 +++++++++++++------ .../galley/src/Galley/Intra/Push/Internal.hs | 1 + 4 files changed, 35 insertions(+), 13 deletions(-) diff --git a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs index c82067837a..d1c45d01d1 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs @@ -125,6 +125,12 @@ data RecipientClients RecipientClientsSome (List1 ClientId) deriving (Eq, Show, Ord) +instance Semigroup RecipientClients where + RecipientClientsAll <> _ = RecipientClientsAll + _ <> RecipientClientsAll = RecipientClientsAll + RecipientClientsSome cs1 <> RecipientClientsSome cs2 = + RecipientClientsSome (cs1 <> cs2) + makeLenses ''Recipient recipient :: UserId -> Route -> Recipient diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index da90671702..f63a790bee 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -20,6 +20,8 @@ module Galley.API.MLS.Propagate where import Control.Comonad import Data.Id import Data.Json.Util +import Data.List.NonEmpty (nonEmpty) +import Data.List1 import Data.Map qualified as Map import Data.Qualified import Data.Time @@ -29,7 +31,10 @@ import Galley.API.Util import Galley.Data.Services import Galley.Effects import Galley.Effects.BackendNotificationQueueAccess +import Galley.Effects.FederatorAccess +import Galley.Intra.Push.Internal import Galley.Types.Conversations.Members +import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports import Network.AMQP qualified as Q import Polysemy @@ -80,7 +85,7 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do e = Event qcnv sconv qusr now $ EdMLSMessage msg.raw runMessagePush lConvOrSub (Just qcnv) $ - newMessagePush botMap con mm (lmems >>= localMemberMLSClients mlsConv) e + newMessagePush botMap con mm (lmems >>= toList . localMemberRecipient mlsConv) e -- send to remotes (either (logRemoteNotificationError @"on-mls-message-sent") (const (pure ())) <=< enqueueNotificationsConcurrently Q.Persistent (map remoteMemberQualify rmems)) $ @@ -97,13 +102,13 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do } where cmWithoutSender = maybe cm (flip cmRemoveClient cm . mkClientIdentity qusr) mSenderClient - localMemberMLSClients :: Local x -> LocalMember -> [(UserId, ClientId)] - localMemberMLSClients loc lm = + + localMemberRecipient :: Local x -> LocalMember -> Maybe Recipient + localMemberRecipient loc lm = do let localUserQId = tUntagged (qualifyAs loc localUserId) localUserId = lmId lm - in map - (\(c, _) -> (localUserId, c)) - (Map.assocs (Map.findWithDefault mempty localUserQId cmWithoutSender)) + clients <- nonEmpty $ Map.keys (Map.findWithDefault mempty localUserQId cmWithoutSender) + pure $ Recipient localUserId (RecipientClientsSome (List1 clients)) remoteMemberMLSClients :: RemoteMember -> [(UserId, ClientId)] remoteMemberMLSClients rm = diff --git a/services/galley/src/Galley/API/Push.hs b/services/galley/src/Galley/API/Push.hs index 51ba1db90f..69ce362e5c 100644 --- a/services/galley/src/Galley/API/Push.hs +++ b/services/galley/src/Galley/API/Push.hs @@ -53,22 +53,32 @@ data MessagePush type BotMap = Map UserId BotMember +class ToRecipient a where + toRecipient :: a -> Recipient + +instance ToRecipient (UserId, ClientId) where + toRecipient (u, c) = Recipient u (RecipientClientsSome (List1.singleton c)) + +instance ToRecipient Recipient where + toRecipient = id + newMessagePush :: + ToRecipient r => BotMap -> Maybe ConnId -> MessageMetadata -> - [(UserId, ClientId)] -> + [r] -> Event -> MessagePush newMessagePush botMap mconn mm userOrBots event = let (recipients, botMembers) = foldMap - ( \(u, c) -> - case Map.lookup u botMap of + ( \r -> + case Map.lookup (_recipientUserId r) botMap of Just botMember -> ([], [botMember]) - Nothing -> ([Recipient u (RecipientClientsSome (List1.singleton c))], []) + Nothing -> ([r], []) ) - userOrBots + (map toRecipient userOrBots) in MessagePush mconn mm recipients botMembers event runMessagePush :: @@ -90,9 +100,9 @@ runMessagePush loc mqcnv mp@(MessagePush _ _ _ botMembers event) = do else deliverAndDeleteAsync (qUnqualified qcnv) (map (,event) botMembers) toPush :: MessagePush -> Maybe Push -toPush (MessagePush mconn mm userRecipients _ event) = +toPush (MessagePush mconn mm rs _ event) = let usr = qUnqualified (evtFrom event) - in newPush ListComplete (Just usr) (ConvEvent event) userRecipients + in newPush ListComplete (Just usr) (ConvEvent event) rs <&> set pushConn mconn . set pushNativePriority (mmNativePriority mm) . set pushRoute (bool RouteDirect RouteAny (mmNativePush mm)) diff --git a/services/galley/src/Galley/Intra/Push/Internal.hs b/services/galley/src/Galley/Intra/Push/Internal.hs index 272a459349..a5389082c8 100644 --- a/services/galley/src/Galley/Intra/Push/Internal.hs +++ b/services/galley/src/Galley/Intra/Push/Internal.hs @@ -24,6 +24,7 @@ import Control.Lens (makeLenses, set, view, (.~)) import Data.Aeson (Object) import Data.Id (ConnId, UserId) import Data.Json.Util +import Data.List.Extra import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.List1 import Data.Qualified From 2faadcf51e2b97b48d08e41dc0aeb16812aaf81e Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 28 Sep 2023 16:41:45 +0200 Subject: [PATCH 3/5] Fix remote MLS message notifications Reorganise remote MLS message recipients by user, so that notifications can be more easily reconstructed on the receiving side. --- integration/test/Test/MLS/Message.hs | 14 +++++++------ .../src/Wire/API/Federation/API/Galley.hs | 3 ++- services/galley/src/Galley/API/Federation.hs | 11 ++++++++-- .../galley/src/Galley/API/MLS/Propagate.hs | 21 ++++++++++++------- services/galley/src/Galley/API/Push.hs | 12 ++++------- services/galley/test/integration/API/MLS.hs | 3 ++- 6 files changed, 38 insertions(+), 26 deletions(-) diff --git a/integration/test/Test/MLS/Message.hs b/integration/test/Test/MLS/Message.hs index e2deb2fadb..7282cfd700 100644 --- a/integration/test/Test/MLS/Message.hs +++ b/integration/test/Test/MLS/Message.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} module Test.MLS.Message where @@ -54,18 +54,20 @@ testAppMessageSomeReachable = do void $ createApplicationMessage alice1 "hi, bob!" >>= sendAndConsumeMessage -testMessageNotifications :: HasCallStack => App () -testMessageNotifications = do - [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] +testMessageNotifications :: HasCallStack => Domain -> App () +testMessageNotifications bobDomain = do + [alice, bob] <- createAndConnectUsers [OwnDomain, bobDomain] [alice1, alice2, bob1, bob2] <- traverse (createMLSClient def) [alice, alice, bob, bob] - aliceClient <- alice1 %. "client_id" & asString bobClient <- bob1 %. "client_id" & asString traverse_ uploadNewKeyPackage [alice1, alice2, bob1, bob2] void $ createNewGroup alice1 - void $ createAddCommit alice1 [alice, bob] >>= sendAndConsumeCommitBundle + + void $ withWebSocket bob $ \ws -> do + void $ createAddCommit alice1 [alice, bob] >>= sendAndConsumeCommitBundle + awaitMatch 10 isMemberJoinNotif ws let get (opts :: GetNotifications) = do notifs <- getNotifications bob opts {size = Just 10000} >>= getJSON 200 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 7e042a0afa..a635ee1cbf 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 @@ -21,6 +21,7 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Domain import Data.Id import Data.Json.Util +import Data.List.NonEmpty (NonEmpty) import Data.Misc (Milliseconds) import Data.Qualified import Data.Range @@ -348,7 +349,7 @@ data RemoteMLSMessage = RemoteMLSMessage sender :: Qualified UserId, conversation :: ConvId, subConversation :: Maybe SubConvId, - recipients :: [(UserId, ClientId)], + recipients :: Map UserId (NonEmpty ClientId), message :: Base64ByteString } deriving stock (Eq, Show, Generic) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index cced908c9f..d7f2e3539a 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -27,6 +27,7 @@ import Data.ByteString.Conversion (toByteString') import Data.Domain (Domain) import Data.Id import Data.Json.Util +import Data.List1 (List1 (..)) import Data.Map qualified as Map import Data.Map.Lens (toMapOf) import Data.Qualified @@ -57,10 +58,12 @@ import Galley.Effects import Galley.Effects.ConversationStore qualified as E import Galley.Effects.FireAndForget qualified as E import Galley.Effects.MemberStore qualified as E +import Galley.Intra.Push.Internal hiding (push) import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.Conversations.One2One import Galley.Types.UserList (UserList (UserList)) +import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports import Polysemy import Polysemy.Error @@ -781,7 +784,7 @@ onMLSMessageSent domain rmm = assertMLSEnabled loc <- qualifyLocal () let rcnv = toRemoteUnsafe domain rmm.conversation - let users = Set.fromList (map fst rmm.recipients) + let users = Map.keys rmm.recipients (members, allMembers) <- first Set.fromList <$> E.selectRemoteMembers (toList users) rcnv @@ -794,7 +797,11 @@ onMLSMessageSent domain rmm = \ users not in the conversation" :: ByteString ) - let recipients = filter (\(u, _) -> Set.member u members) rmm.recipients + let recipients = + filter (\r -> Set.member (_recipientUserId r) members) + . map (\(u, clts) -> Recipient u (RecipientClientsSome (List1 clts))) + . Map.assocs + $ rmm.recipients -- FUTUREWORK: support local bots let e = Event (tUntagged rcnv) rmm.subConversation rmm.sender rmm.time $ diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index f63a790bee..de95bdefed 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -20,7 +20,7 @@ module Galley.API.MLS.Propagate where import Control.Comonad import Data.Id import Data.Json.Util -import Data.List.NonEmpty (nonEmpty) +import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.List1 import Data.Map qualified as Map import Data.Qualified @@ -31,7 +31,6 @@ import Galley.API.Util import Galley.Data.Services import Galley.Effects import Galley.Effects.BackendNotificationQueueAccess -import Galley.Effects.FederatorAccess import Galley.Intra.Push.Internal import Galley.Types.Conversations.Members import Gundeck.Types.Push.V2 (RecipientClients (..)) @@ -97,7 +96,12 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do metadata = mm, conversation = qUnqualified qcnv, subConversation = sconv, - recipients = tUnqualified rs >>= remoteMemberMLSClients, + recipients = + Map.fromList $ + tUnqualified rs + >>= toList . remoteMemberMLSClients, + -- Map.fromList $ + -- rs >>= toList . remoteMemberMLSClients, message = Base64ByteString msg.raw } where @@ -110,10 +114,11 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do clients <- nonEmpty $ Map.keys (Map.findWithDefault mempty localUserQId cmWithoutSender) pure $ Recipient localUserId (RecipientClientsSome (List1 clients)) - remoteMemberMLSClients :: RemoteMember -> [(UserId, ClientId)] - remoteMemberMLSClients rm = + remoteMemberMLSClients :: RemoteMember -> Maybe (UserId, NonEmpty ClientId) + remoteMemberMLSClients rm = do let remoteUserQId = tUntagged (rmId rm) remoteUserId = qUnqualified remoteUserQId - in map - (\(c, _) -> (remoteUserId, c)) - (Map.assocs (Map.findWithDefault mempty remoteUserQId cmWithoutSender)) + clients <- + nonEmpty . map fst $ + Map.assocs (Map.findWithDefault mempty remoteUserQId cmWithoutSender) + pure (remoteUserId, clients) diff --git a/services/galley/src/Galley/API/Push.hs b/services/galley/src/Galley/API/Push.hs index 69ce362e5c..786a805a29 100644 --- a/services/galley/src/Galley/API/Push.hs +++ b/services/galley/src/Galley/API/Push.hs @@ -71,14 +71,10 @@ newMessagePush :: Event -> MessagePush newMessagePush botMap mconn mm userOrBots event = - let (recipients, botMembers) = - foldMap - ( \r -> - case Map.lookup (_recipientUserId r) botMap of - Just botMember -> ([], [botMember]) - Nothing -> ([r], []) - ) - (map toRecipient userOrBots) + let toPair r = case Map.lookup (_recipientUserId r) botMap of + Just botMember -> ([], [botMember]) + Nothing -> ([r], []) + (recipients, botMembers) = foldMap (toPair . toRecipient) userOrBots in MessagePush mconn mm recipients botMembers event runMessagePush :: diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 6bb5d767a7..806a43b3b3 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -32,6 +32,7 @@ import Data.Aeson qualified as Aeson import Data.Domain import Data.Id import Data.Json.Util hiding ((#)) +import Data.List.NonEmpty (NonEmpty (..)) import Data.List1 hiding (head) import Data.Map qualified as Map import Data.Qualified @@ -890,7 +891,7 @@ testRemoteToRemoteInSub = do void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu let txt = "Hello from another backend" - rcpts = [(alice, aliceC1), (alice, aliceC2), (eve, eveC)] + rcpts = Map.fromList [(alice, aliceC1 :| [aliceC2]), (eve, eveC :| [])] rm = RemoteMLSMessage { time = now, From 88d4e156d7f4008fd3c429414590a5b84231c6dd Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 13 Oct 2023 10:32:04 +0200 Subject: [PATCH 4/5] Add CHANGELOG entry --- changelog.d/3-bug-fixes/mls-notification-bug | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/3-bug-fixes/mls-notification-bug diff --git a/changelog.d/3-bug-fixes/mls-notification-bug b/changelog.d/3-bug-fixes/mls-notification-bug new file mode 100644 index 0000000000..cfe1d68289 --- /dev/null +++ b/changelog.d/3-bug-fixes/mls-notification-bug @@ -0,0 +1 @@ +Fix bug where notifications for MLS messages were not showing up in all notification streams of clients From 9203a83ae05ed4e54e9e7ebcf18205278a650103 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 13 Oct 2023 10:37:02 +0200 Subject: [PATCH 5/5] Remote leftover comment --- services/galley/src/Galley/API/MLS/Propagate.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index de95bdefed..e9f6ac089d 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -100,8 +100,6 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do Map.fromList $ tUnqualified rs >>= toList . remoteMemberMLSClients, - -- Map.fromList $ - -- rs >>= toList . remoteMemberMLSClients, message = Base64ByteString msg.raw } where