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 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 diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index a13db52313..69623ea703 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 @?= 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) $ \wsBob -> do + isTyping galley1 alice StartedTyping + checkEvent wsBob alice StartedTyping + isTyping galley1 alice StoppedTyping + checkEvent wsBob alice StoppedTyping + + -- bob is typing, alice gets events + WS.bracketR cannon1 (userId alice) $ \wsAlice -> do + isTyping galley2 bob StartedTyping + checkEvent wsAlice bob StartedTyping + isTyping galley2 bob StoppedTyping + checkEvent wsAlice bob StoppedTyping 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 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