From 52efb9eeeb08d840288743719b455480555d1ce2 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 2 Mar 2023 10:05:42 +0100 Subject: [PATCH 1/6] Add end2end test for remote typing indicators --- .../test/integration/Federation/End2end.hs | 53 ++++++++++++++++++- 1 file changed, 52 insertions(+), 1 deletion(-) diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index a13db52313..b1b75bb8fd 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -58,6 +58,7 @@ import Wire.API.Asset import Wire.API.Conversation import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role +import Wire.API.Conversation.Typing import Wire.API.Event.Conversation import Wire.API.Internal.Notification (ntfTransient) import Wire.API.MLS.Credential @@ -118,7 +119,9 @@ spec _brigOpts mg brig galley cargohold cannon _federator brigTwo galleyTwo carg test mg "download remote asset" $ testRemoteAsset brig brigTwo cargohold cargoholdTwo, test mg "claim remote key packages" $ claimRemoteKeyPackages brig brigTwo, test mg "send an MLS message to a remote user" $ - testSendMLSMessage brig brigTwo galley galleyTwo cannon cannonTwo + testSendMLSMessage brig brigTwo galley galleyTwo cannon cannonTwo, + test mg "remote typing indicator" $ + testRemoteTypingIndicator brig brigTwo galley galleyTwo cannon cannonTwo ] -- | Path covered by this test: @@ -946,3 +949,51 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do evtType e @?= MLSMessageAdd evtFrom e @?= userQualifiedId alice evtData e @?= EdMLSMessage reply + +testRemoteTypingIndicator :: Brig -> Brig -> Galley -> Galley -> Cannon -> Cannon -> Http () +testRemoteTypingIndicator brig1 brig2 galley1 galley2 cannon1 cannon2 = do + alice <- randomUser brig1 + bob <- randomUser brig2 + + connectUsersEnd2End brig1 brig2 (userQualifiedId alice) (userQualifiedId bob) + + cnv <- + responseJsonError + =<< createConversation galley1 (userId alice) [userQualifiedId bob] + do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= cnvQualifiedId cnv + evtType e @?= Typing + evtFrom e @?= userQualifiedId u + evtData e @?= EdTyping s + + -- alice is typing, bob gets events + WS.bracketR cannon2 (userId bob) $ \ws -> do + isTyping galley1 alice StartedTyping + checkEvent ws alice StartedTyping + isTyping galley1 alice StoppedTyping + checkEvent ws alice StoppedTyping + + -- bob is typing, alice gets events + WS.bracketR cannon1 (userId alice) $ \ws -> do + isTyping galley2 bob StartedTyping + checkEvent ws bob StartedTyping + isTyping galley2 bob StoppedTyping + checkEvent ws bob StoppedTyping From e8dc87a8e1daf69342bfcde54350a7759155b899 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 2 Mar 2023 16:15:44 +0100 Subject: [PATCH 2/6] remove incorrect tests --- services/galley/test/integration/API.hs | 198 +----------------------- 1 file changed, 1 insertion(+), 197 deletions(-) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 7e2bf34276..f51aca7fea 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -244,10 +244,7 @@ tests s = "Typing indicators" [ test s "send typing indicators" postTypingIndicators, test s "send typing indicators without domain" postTypingIndicatorsV2, - test s "send typing indicators with invalid pyaload" postTypingIndicatorsHandlesNonsense, - test s "POST /federation/on-typing-indicator-updated : Update typing indicator by remote user" updateTypingIndicatorFromRemoteUser, - test s "POST /federation/on-typing-indicator-updated : Update typing indicator to remote user" updateTypingIndicatorToRemoteUser, - test s "send typing indicator update from local to remote on remote conv" updateTypingIndicatorToRemoteUserRemoteConv + test s "send typing indicators with invalid pyaload" postTypingIndicatorsHandlesNonsense ] ] @@ -4016,196 +4013,3 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do pure $ statusCode resp == 200 liftIO $ found @?= ((actor, desired) == (LocalActor, Included)) ) - -updateTypingIndicatorToRemoteUserRemoteConv :: TestM () -updateTypingIndicatorToRemoteUserRemoteConv = do - c <- view tsCannon - qalice <- randomQualifiedUser - let alice = qUnqualified qalice - - -- create a remote conversation with alice - let remoteDomain = Domain "bobland.example.com" - qbob <- Qualified <$> randomId <*> pure remoteDomain - qconv <- Qualified <$> randomId <*> pure remoteDomain - connectWithRemoteUser alice qbob - - fedGalleyClient <- view tsFedGalleyClient - now <- liftIO getCurrentTime - let cu = - F.ConversationUpdate - { cuTime = now, - cuOrigUserId = qbob, - cuConvId = qUnqualified qconv, - cuAlreadyPresentUsers = [], - cuAction = - SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) - } - runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cu - - -- Fetch remote conversation - let bobAsLocal = - LocalMember - (qUnqualified qbob) - defMemberStatus - Nothing - roleNameWireAdmin - let mockConversation = - mkProteusConv - (qUnqualified qconv) - (qUnqualified qbob) - roleNameWireMember - [localMemberToOther remoteDomain bobAsLocal] - remoteConversationResponse = GetConversationsResponse [mockConversation] - void - $ withTempMockFederator' - (mockReply remoteConversationResponse) - $ getConvQualified alice qconv - do - -- Started - void $ - withTempMockFederator' (mockReply ()) $ do - -- post typing indicator from bob to alice - let tcReq = - TypingDataUpdateRequest - { tdurTypingStatus = StartedTyping, - tdurUserId = qUnqualified qbob, - tdurConvId = qUnqualified qconv - } - - runFedClient @"on-typing-indicator-updated" fedGalleyClient (qDomain qalice) tcReq - - -- backend A generates a notification for alice - void $ - WS.awaitMatch (5 # Second) wsAlice $ \n -> do - liftIO $ wsAssertTyping qconv qalice StartedTyping n - - -- stopped - void $ - withTempMockFederator' (mockReply ()) $ do - -- post typing indicator from bob to alice - let tcReq = - TypingDataUpdateRequest - { tdurTypingStatus = StoppedTyping, - tdurUserId = qUnqualified qbob, - tdurConvId = qUnqualified qconv - } - - runFedClient @"on-typing-indicator-updated" fedGalleyClient (qDomain qalice) tcReq - - -- backend A generates a notification for alice - void $ - WS.awaitMatch (5 # Second) wsAlice $ \n -> do - liftIO $ wsAssertTyping qconv qalice StoppedTyping n - -updateTypingIndicatorFromRemoteUser :: TestM () -updateTypingIndicatorFromRemoteUser = do - localDomain <- viewFederationDomain - [alice, bob] <- randomUsers 2 - let qAlice = Qualified alice localDomain - remoteDomain = Domain "far-away.example.com" - qBob = Qualified bob remoteDomain - - connectWithRemoteUser alice qBob - convId <- - decodeConvId - <$> postConvWithRemoteUsers - alice - defNewProteusConv {newConvQualifiedUsers = [qBob]} - let qconvId = Qualified convId localDomain - - c <- view tsCannon - WS.bracketR c alice $ \wsAlice -> do - -- Started - void $ - withTempMockFederator' (mockReply ()) $ do - -- post typing indicator from bob to alice - let tcReq = - TypingDataUpdateRequest - { tdurTypingStatus = StartedTyping, - tdurUserId = bob, - tdurConvId = convId - } - - fedGalleyClient <- view tsFedGalleyClient - runFedClient @"on-typing-indicator-updated" fedGalleyClient (qDomain qAlice) tcReq - - -- backend A generates a notification for alice - void $ - WS.awaitMatch (5 # Second) wsAlice $ \n -> do - liftIO $ wsAssertTyping qconvId qAlice StartedTyping n - - -- stopped - void $ - withTempMockFederator' (mockReply ()) $ do - -- post typing indicator from bob to alice - let tcReq = - TypingDataUpdateRequest - { tdurTypingStatus = StoppedTyping, - tdurUserId = bob, - tdurConvId = convId - } - - fedGalleyClient <- view tsFedGalleyClient - runFedClient @"on-typing-indicator-updated" fedGalleyClient (qDomain qAlice) tcReq - - -- backend A generates a notification for alice - void $ - WS.awaitMatch (5 # Second) wsAlice $ \n -> do - liftIO $ wsAssertTyping qconvId qAlice StoppedTyping n - -updateTypingIndicatorToRemoteUser :: TestM () -updateTypingIndicatorToRemoteUser = do - localDomain <- viewFederationDomain - [alice, bob] <- randomUsers 2 - let remoteDomain = Domain "far-away.example.com" - qBob = Qualified bob remoteDomain - - connectWithRemoteUser alice qBob - convId <- - decodeConvId - <$> postConvWithRemoteUsers - alice - defNewProteusConv {newConvQualifiedUsers = [qBob]} - let qconvId = Qualified convId localDomain - - c <- view tsCannon - WS.bracketR c bob $ \wsBob -> do - -- started - void $ - withTempMockFederator' (mockReply ()) $ do - -- post typing indicator from alice to bob - let tcReq = - TypingDataUpdateRequest - { tdurTypingStatus = StartedTyping, - tdurUserId = alice, - tdurConvId = convId - } - - fedGalleyClient <- view tsFedGalleyClient - runFedClient @"on-typing-indicator-updated" fedGalleyClient (qDomain qBob) tcReq - - -- backend A generates a notification for bob - void $ - WS.awaitMatch (5 # Second) wsBob $ \n -> do - liftIO $ wsAssertTyping qconvId qBob StartedTyping n - - -- stopped - void $ - withTempMockFederator' (mockReply ()) $ do - -- post typing indicator from alice to bob - let tcReq = - TypingDataUpdateRequest - { tdurTypingStatus = StoppedTyping, - tdurUserId = alice, - tdurConvId = convId - } - - fedGalleyClient <- view tsFedGalleyClient - runFedClient @"on-typing-indicator-updated" fedGalleyClient (qDomain qBob) tcReq - - -- backend A generates a notification for bob - void $ - WS.awaitMatch (5 # Second) wsBob $ \n -> do - liftIO $ wsAssertTyping qconvId qBob StoppedTyping n From 2ed6e48880d6588cd8885874b375ab3e807d4a37 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 3 Mar 2023 12:59:10 +0100 Subject: [PATCH 3/6] end2end test: event should be transient --- .../brig/test/integration/Federation/End2end.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index b1b75bb8fd..69623ea703 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -978,22 +978,22 @@ testRemoteTypingIndicator brig1 brig2 galley1 galley2 cannon1 cannon2 = do let checkEvent ws u s = WS.assertMatch_ (5 # Second) ws $ \n -> do let e = List1.head (WS.unpackPayload n) - ntfTransient n @?= False + ntfTransient n @?= True evtConv e @?= cnvQualifiedId cnv evtType e @?= Typing evtFrom e @?= userQualifiedId u evtData e @?= EdTyping s - -- alice is typing, bob gets events - WS.bracketR cannon2 (userId bob) $ \ws -> do + -- -- alice is typing, bob gets events + WS.bracketR cannon2 (userId bob) $ \wsBob -> do isTyping galley1 alice StartedTyping - checkEvent ws alice StartedTyping + checkEvent wsBob alice StartedTyping isTyping galley1 alice StoppedTyping - checkEvent ws alice StoppedTyping + checkEvent wsBob alice StoppedTyping -- bob is typing, alice gets events - WS.bracketR cannon1 (userId alice) $ \ws -> do + WS.bracketR cannon1 (userId alice) $ \wsAlice -> do isTyping galley2 bob StartedTyping - checkEvent ws bob StartedTyping + checkEvent wsAlice bob StartedTyping isTyping galley2 bob StoppedTyping - checkEvent ws bob StoppedTyping + checkEvent wsAlice bob StoppedTyping From 147731a9477aacd91efcf0af9d1e0f35e5bba49e Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 3 Mar 2023 12:59:46 +0100 Subject: [PATCH 4/6] Fix: federated endpoint not using with on- convention --- docs/src/understand/federation/api.md | 1 + .../src/Wire/API/Federation/API/Galley.hs | 26 ++++++++++++++++++- .../API/Routes/Public/Galley/Conversation.hs | 3 +++ 3 files changed, 29 insertions(+), 1 deletion(-) diff --git a/docs/src/understand/federation/api.md b/docs/src/understand/federation/api.md index 7b576d9234..f993459102 100644 --- a/docs/src/understand/federation/api.md +++ b/docs/src/understand/federation/api.md @@ -200,6 +200,7 @@ to synchronize the state of the conversations of their members. remote user in a conversation (see end-to-end flows). - `on-mls-message-sent`: Receive a MLS message that originates in the calling backend - `on-new-remote-conversation`: Inform the called backend about a conversation that exists on the calling backend. This request is made before the first time the backend might learn about this conversation, e.g. when its first user is added to the conversation. +- `update-typing-indicator`: Used by the calling backend (that does not own the conversation ) to inform the backend about a change of the typing indicator status of one of its users - `on-typing-indicator-updated`: Used by the calling backend (that owns a conversation) to inform the called backend about a change of the typing indicator status of remote user - `on-user-deleted-conversations`: When a user on calling backend this request is made for all conversations on the called backend was part of - `query-group-info`: Query the MLS public group state 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 fb32aa2451..158aedfa53 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 @@ -126,7 +126,13 @@ type GalleyApi = "on-client-removed" ClientRemovedRequest EmptyResponse - :<|> FedEndpoint "on-typing-indicator-updated" TypingDataUpdateRequest EmptyResponse + :<|> FedEndpointWithMods + '[ MakesFederatedCall 'Galley "on-typing-indicator-updated" + ] + "update-typing-indicator" + TypingDataUpdateRequest + TypingDataUpdateResponse + :<|> FedEndpoint "on-typing-indicator-updated" TypingDataUpdated EmptyResponse data TypingDataUpdateRequest = TypingDataUpdateRequest { tdurTypingStatus :: TypingStatus, @@ -136,6 +142,24 @@ data TypingDataUpdateRequest = TypingDataUpdateRequest deriving stock (Eq, Show, Generic) deriving (FromJSON, ToJSON) via (CustomEncoded TypingDataUpdateRequest) +data TypingDataUpdateResponse + = TypingDataUpdateSuccess TypingDataUpdated + | TypingDataUpdateError GalleyError + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via (CustomEncoded TypingDataUpdateResponse) + +data TypingDataUpdated = TypingDataUpdated + { tudTime :: UTCTime, + tudOrigUserId :: Qualified UserId, + -- | Implicitely qualified by sender's domain + tudConvId :: ConvId, + -- | Implicitely qualified by receiver's domain + tudUsersInConv :: [UserId], + tudTypingStatus :: TypingStatus + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via (CustomEncoded TypingDataUpdated) + data ClientRemovedRequest = ClientRemovedRequest { crrUser :: UserId, crrClient :: ClientId, diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs index 65dc97b08b..d3f41cfee9 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs @@ -645,6 +645,8 @@ type ConversationAPI = "member-typing-unqualified" ( Summary "Sending typing notifications" :> Until 'V3 + :> MakesFederatedCall 'Galley "update-typing-indicator" + :> MakesFederatedCall 'Galley "on-typing-indicator-updated" :> CanThrow 'ConvNotFound :> ZLocalUser :> ZConn @@ -657,6 +659,7 @@ type ConversationAPI = :<|> Named "member-typing-qualified" ( Summary "Sending typing notifications" + :> MakesFederatedCall 'Galley "update-typing-indicator" :> MakesFederatedCall 'Galley "on-typing-indicator-updated" :> CanThrow 'ConvNotFound :> ZLocalUser From d1de23d6b634ad8c1984f9b2a06a3f37e77098fc Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 3 Mar 2023 13:00:41 +0100 Subject: [PATCH 5/6] Rework fed and client endpoints --- services/galley/src/Galley/API/Action.hs | 57 +++++++++++++++++++ services/galley/src/Galley/API/Federation.hs | 36 ++++++++---- .../src/Galley/API/Public/Conversation.hs | 4 +- services/galley/src/Galley/API/Update.hs | 54 +++++++++++------- services/galley/src/Galley/API/Util.hs | 26 --------- 5 files changed, 117 insertions(+), 60 deletions(-) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 7467c3ff90..f81190f798 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -28,6 +28,8 @@ module Galley.API.Action updateLocalConversationUnchecked, NoChanges (..), LocalConversationUpdate (..), + notifyTypingIndicator, + pushTypingIndicatorEvents, -- * Utilities ensureConversationActionAllowed, @@ -43,6 +45,7 @@ import Control.Lens import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Kind +import qualified Data.List as List import Data.List.NonEmpty (nonEmpty) import qualified Data.Map as Map import Data.Misc @@ -65,9 +68,11 @@ import qualified Galley.Effects.CodeStore as E import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.FederatorAccess as E import qualified Galley.Effects.FireAndForget as E +import Galley.Effects.GundeckAccess import qualified Galley.Effects.MemberStore as E import Galley.Effects.ProposalStore import qualified Galley.Effects.TeamStore as E +import Galley.Intra.Push import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.UserList @@ -83,6 +88,7 @@ import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.Conversation.Action import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role +import Wire.API.Conversation.Typing import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation @@ -816,3 +822,54 @@ kickMember qusr lconv targets victim = void . runError @NoChanges $ do lconv (targets <> extraTargets) (pure victim) + +notifyTypingIndicator :: + ( Member (Input UTCTime) r, + Member (Input (Local ())) r, + Member GundeckAccess r, + Member FederatorAccess r + ) => + Conversation -> + Qualified UserId -> + Maybe ConnId -> + TypingStatus -> + Sem r TypingDataUpdated +notifyTypingIndicator conv qusr mcon ts = do + let origDomain = qDomain qusr + now <- input + lconv <- qualifyLocal (Data.convId conv) + + pushTypingIndicatorEvents qusr now (fmap lmId (Data.convLocalMembers conv)) mcon (tUntagged lconv) ts + + let (remoteMemsOrig, remoteMemsOther) = List.partition ((origDomain ==) . tDomain . rmId) (Data.convRemoteMembers conv) + let tdu users = + TypingDataUpdated + { tudTime = now, + tudOrigUserId = qusr, + tudConvId = Data.convId conv, + tudUsersInConv = users, + tudTypingStatus = ts + } + + void $ E.runFederatedConcurrentlyEither (fmap rmId remoteMemsOther) $ \rmems -> do + fedClient @'Galley @"on-typing-indicator-updated" (tdu (tUnqualified rmems)) + + pure (tdu (fmap (tUnqualified . rmId) remoteMemsOrig)) + +pushTypingIndicatorEvents :: + (Member GundeckAccess r) => + Qualified UserId -> + UTCTime -> + [UserId] -> + Maybe ConnId -> + Qualified ConvId -> + TypingStatus -> + Sem r () +pushTypingIndicatorEvents qusr tEvent users mcon qcnv ts = do + let e = Event qcnv Nothing qusr tEvent (EdTyping ts) + for_ (newPushLocal ListComplete (qUnqualified qusr) (ConvEvent e) (userRecipient <$> users)) $ \p -> + push1 $ + p + & pushConn .~ mcon + & pushRoute .~ RouteDirect + & pushTransient .~ True diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 6610a5cbf6..7850852ab2 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -118,6 +118,7 @@ federationSitemap = :<|> Named @"send-mls-commit-bundle" (callsFed (exposeAnnotations sendMLSCommitBundle)) :<|> Named @"query-group-info" queryGroupInfo :<|> Named @"on-client-removed" (callsFed (exposeAnnotations onClientRemoved)) + :<|> Named @"update-typing-indicator" (callsFed (exposeAnnotations updateTypingIndicator)) :<|> Named @"on-typing-indicator-updated" onTypingIndicatorUpdated onClientRemoved :: @@ -793,20 +794,35 @@ queryGroupInfo origDomain req = . unOpaquePublicGroupState $ state -onTypingIndicatorUpdated :: - ( Member MemberStore r, - Member GundeckAccess r, +updateTypingIndicator :: + ( Member GundeckAccess r, + Member FederatorAccess r, + Member ConversationStore r, Member (Input UTCTime) r, Member (Input (Local ())) r ) => Domain -> - TypingDataUpdateRequest -> - Sem r EmptyResponse -onTypingIndicatorUpdated origDomain TypingDataUpdateRequest {..} = do + F.TypingDataUpdateRequest -> + Sem r F.TypingDataUpdateResponse +updateTypingIndicator origDomain TypingDataUpdateRequest {..} = do let qusr = Qualified tdurUserId origDomain lcnv <- qualifyLocal tdurConvId - -- FUTUREWORK: Consider if we should throw exceptions from this kind of function - void $ - runError @(Tagged 'ConvNotFound ()) $ - isTyping qusr Nothing lcnv tdurTypingStatus + + ret <- runError + . mapToRuntimeError @'ConvNotFound ConvNotFound + $ do + (conv, _) <- getConversationAndMemberWithError @'ConvNotFound qusr lcnv + notifyTypingIndicator conv qusr Nothing tdurTypingStatus + + pure (either TypingDataUpdateError TypingDataUpdateSuccess ret) + +onTypingIndicatorUpdated :: + ( Member GundeckAccess r + ) => + Domain -> + TypingDataUpdated -> + Sem r EmptyResponse +onTypingIndicatorUpdated origDomain TypingDataUpdated {..} = do + let qcnv = Qualified tudConvId origDomain + pushTypingIndicatorEvents tudOrigUserId tudTime tudUsersInConv Nothing qcnv tudTypingStatus pure EmptyResponse diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index b6f74c525d..73bb3cb575 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -61,8 +61,8 @@ conversationAPI = <@> mkNamedAPI @"get-conversation-guest-links-status" (getConversationGuestLinksStatus @Cassandra) <@> mkNamedAPI @"remove-code-unqualified" rmCodeUnqualified <@> mkNamedAPI @"get-code" (getCode @Cassandra) - <@> mkNamedAPI @"member-typing-unqualified" isTypingUnqualified - <@> mkNamedAPI @"member-typing-qualified" (callsFed (exposeAnnotations isTypingQualified)) + <@> mkNamedAPI @"member-typing-unqualified" (callsFed (exposeAnnotations memberTypingUnqualified)) + <@> mkNamedAPI @"member-typing-qualified" (callsFed (exposeAnnotations memberTyping)) <@> mkNamedAPI @"remove-member-unqualified" (callsFed (exposeAnnotations removeMemberUnqualified)) <@> mkNamedAPI @"remove-member" (callsFed (exposeAnnotations removeMemberQualified)) <@> mkNamedAPI @"update-other-member-unqualified" (callsFed (exposeAnnotations updateOtherMemberUnqualified)) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 8243d941c8..b431ed747e 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.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 . +{-# LANGUAGE RecordWildCards #-} module Galley.API.Update ( -- * Managing Conversations @@ -55,8 +56,8 @@ module Galley.API.Update postOtrMessageUnqualified, postProteusBroadcast, postOtrBroadcastUnqualified, - isTypingUnqualified, - isTypingQualified, + memberTypingUnqualified, + memberTyping, -- * External Services addServiceH, @@ -1331,11 +1332,12 @@ updateLocalConversationName lusr zcon lcnv rename = getUpdateResult . fmap lcuEvent $ updateLocalConversation @'ConversationRenameTag lcnv (tUntagged lusr) (Just zcon) rename -isTypingQualified :: +memberTyping :: ( Member GundeckAccess r, Member (ErrorS 'ConvNotFound) r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member ConversationStore r, Member MemberStore r, Member FederatorAccess r ) => @@ -1344,39 +1346,47 @@ isTypingQualified :: Qualified ConvId -> TypingStatus -> Sem r () -isTypingQualified lusr zcon qcnv ts = do +memberTyping lusr zcon qcnv ts = do foldQualified lusr - (\lcnv -> isTypingUnqualified lusr zcon (tUnqualified lcnv) ts) - (\rcnv -> isTypingRemote rcnv) + ( \lcnv -> do + (conv, _) <- getConversationAndMemberWithError @'ConvNotFound (tUntagged lusr) lcnv + void $ notifyTypingIndicator conv (tUntagged lusr) (Just zcon) ts + ) + ( \rcnv -> do + isMemberRemoteConv <- E.checkLocalMemberRemoteConv (tUnqualified lusr) rcnv + unless isMemberRemoteConv $ throwS @'ConvNotFound + let rpc = + TypingDataUpdateRequest + { tdurTypingStatus = ts, + tdurUserId = tUnqualified lusr, + tdurConvId = tUnqualified rcnv + } + res <- E.runFederated rcnv (fedClient @'Galley @"update-typing-indicator" rpc) + case res of + TypingDataUpdateSuccess (TypingDataUpdated {..}) -> do + pushTypingIndicatorEvents tudOrigUserId tudTime tudUsersInConv (Just zcon) qcnv tudTypingStatus + TypingDataUpdateError _ -> pure () + ) qcnv - where - isTypingRemote rcnv = do - isMemberRemoteConv <- E.checkLocalMemberRemoteConv (tUnqualified lusr) rcnv - unless isMemberRemoteConv $ throwS @'ConvNotFound - let rpc = - TypingDataUpdateRequest - { tdurTypingStatus = ts, - tdurUserId = tUnqualified lusr, - tdurConvId = tUnqualified rcnv - } - void $ E.runFederated rcnv (fedClient @'Galley @"on-typing-indicator-updated" rpc) - -isTypingUnqualified :: + +memberTypingUnqualified :: ( Member GundeckAccess r, Member (ErrorS 'ConvNotFound) r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member MemberStore r + Member MemberStore r, + Member ConversationStore r, + Member FederatorAccess r ) => Local UserId -> ConnId -> ConvId -> TypingStatus -> Sem r () -isTypingUnqualified lusr zcon cnv ts = do +memberTypingUnqualified lusr zcon cnv ts = do lcnv <- qualifyLocal cnv - isTyping (tUntagged lusr) (Just zcon) lcnv ts + memberTyping lusr zcon (tUntagged lcnv) ts addServiceH :: ( Member ServiceStore r, diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 51595a43d3..33ce13bbeb 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -70,7 +70,6 @@ import Wire.API.Conversation hiding (Member) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role -import Wire.API.Conversation.Typing import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation @@ -912,28 +911,3 @@ instance if err' == demote @e then throwS @e else rethrowErrors @effs @r err' - --------------------------------------------------------------------------------- --- Send typing indicator events -isTyping :: - ( Member (ErrorS 'ConvNotFound) r, - Member GundeckAccess r, - Member (Input UTCTime) r, - Member MemberStore r - ) => - Qualified UserId -> - Maybe ConnId -> - Local ConvId -> - TypingStatus -> - Sem r () -isTyping qusr mcon lcnv ts = do - mm <- getLocalMembers (tUnqualified lcnv) - unless (qUnqualified qusr `isMember` mm) $ throwS @'ConvNotFound - now <- input - let e = Event (tUntagged lcnv) Nothing qusr now (EdTyping ts) - for_ (newPushLocal ListComplete (qUnqualified qusr) (ConvEvent e) (recipient <$> mm)) $ \p -> - push1 $ - p - & pushConn .~ mcon - & pushRoute .~ RouteDirect - & pushTransient .~ True From d8c4f4992abf773c2d457992e2ce7b663053d32f Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 3 Mar 2023 13:07:58 +0100 Subject: [PATCH 6/6] Add changelog entry --- changelog.d/3-bug-fixes/typing-indicator | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/3-bug-fixes/typing-indicator diff --git a/changelog.d/3-bug-fixes/typing-indicator b/changelog.d/3-bug-fixes/typing-indicator new file mode 100644 index 0000000000..82a04a4eb2 --- /dev/null +++ b/changelog.d/3-bug-fixes/typing-indicator @@ -0,0 +1 @@ +Typing indicators not working accross federated backends