Remote typing indicators

changelog.d/3-bug-fixes/typing-indicator

@@ -0,0 +1 @@
+Typing indicators not working accross federated backends

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

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,

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

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]
+        <!! const 201 === statusCode
+  let isTyping g u s =
+        post
+          ( g
+              . paths
+                [ "conversations",
+                  toByteString' (qDomain (cnvQualifiedId cnv)),
+                  toByteString' (qUnqualified (cnvQualifiedId cnv)),
+                  "typing"
+                ]
+              . zUser (userId u)
+              . zConn "conn"
+              . json s
+          )
+          !!! const 200 === statusCode
+  let checkEvent ws u s =
+        WS.assertMatch_ (5 # Second) ws $ \n -> 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

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

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

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))

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 <https://www.gnu.org/licenses/>.
+{-# 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,