Federation: support read receipts

changelog.d/5-internal/member-update-refactoring

@@ -0,0 +1,3 @@
+Refactored a few functions dealing with conversation updates, in an attempt to
+make the conversation update code paths more uniform, and also reduce special
+cases for local and remote objects.

changelog.d/6-federation/fed-receipt-mode

@@ -0,0 +1 @@
+Notify remote users when a conversation receipt mode is updated

libs/types-common/src/Data/Qualified.hs

@@ -27,6 +27,7 @@ module Data.Qualified
     toLocal,
     lUnqualified,
     lDomain,
+    qualifyAs,
     foldQualified,
     renderQualifiedId,
     partitionRemoteOrLocalIds,
@@ -59,7 +60,7 @@ data Qualified a = Qualified
   { qUnqualified :: a,
     qDomain :: Domain
   }
-  deriving stock (Eq, Ord, Show, Generic, Functor)
+  deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable)
 
 -- | A type to differentiate between generally Qualified values, and values
 -- where it is known if they are coming from a Remote backend or not.
@@ -84,6 +85,11 @@ lUnqualified = qUnqualified . unTagged
 lDomain :: Local a -> Domain
 lDomain = qDomain . unTagged
 
+-- | Convert an unqualified value to a qualified one, with the same tag as the
+-- given tagged qualified value.
+qualifyAs :: Tagged t (Qualified x) -> a -> Tagged t (Qualified a)
+qualifyAs (Tagged q) x = Tagged (q $> x)
+
 foldQualified :: Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
 foldQualified loc f g q
   | lDomain loc == qDomain q =
@@ -108,13 +114,13 @@ partitionRemoteOrLocalIds' :: Foldable f => Domain -> f (Qualified a) -> ([Remot
 partitionRemoteOrLocalIds' localDomain xs = first (fmap toRemote) $ partitionRemoteOrLocalIds localDomain xs
 
 -- | Index a list of qualified values by domain
-partitionQualified :: [Qualified a] -> Map Domain [a]
+partitionQualified :: Foldable f => f (Qualified a) -> Map Domain [a]
 partitionQualified = foldr add mempty
   where
     add :: Qualified a -> Map Domain [a] -> Map Domain [a]
     add (Qualified x domain) = Map.insertWith (<>) domain [x]
 
-partitionRemote :: [Remote a] -> [(Domain, [a])]
+partitionRemote :: (Functor f, Foldable f) => f (Remote a) -> [(Domain, [a])]
 partitionRemote remotes = Map.assocs $ partitionQualified (unTagged <$> remotes)
 
 ----------------------------------------------------------------------

libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs

@@ -28,7 +28,7 @@ import Data.Qualified (Qualified (Qualified))
 import qualified Data.UUID as UUID
 import Imports
 import Wire.API.Conversation.Action
-import Wire.API.Conversation.Role (roleNameWireAdmin, roleNameWireMember)
+import Wire.API.Conversation.Role (roleNameWireAdmin)
 import Wire.API.Federation.API.Galley (ConversationUpdate (..))
 
 qAlice, qBob :: Qualified UserId
@@ -56,7 +56,7 @@ testObject_ConversationUpdate1 =
       cuConvId =
         Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")),
       cuAlreadyPresentUsers = [],
-      cuAction = ConversationActionAddMembers ((qAlice, roleNameWireMember) :| [(qBob, roleNameWireAdmin)])
+      cuAction = ConversationActionAddMembers (qAlice :| [qBob]) roleNameWireAdmin
     }
 
 testObject_ConversationUpdate2 :: ConversationUpdate
@@ -70,5 +70,5 @@ testObject_ConversationUpdate2 =
       cuConvId =
         Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")),
       cuAlreadyPresentUsers = [chad, dee],
-      cuAction = ConversationActionRemoveMembers (qAlice :| [qBob])
+      cuAction = ConversationActionRemoveMember (qAlice)
     }

libs/wire-api-federation/test/golden/testObject_ConversationUpdate1.json

@@ -13,15 +13,12 @@
                     "domain": "golden.example.com",
                     "id": "00000000-0000-0000-0000-000100004007"
                 },
-                "wire_member"
-            ],
-            [
                 {
                     "domain": "golden2.example.com",
                     "id": "00000000-0000-0000-0000-000100005007"
-                },
-                "wire_admin"
-            ]
+                }
+            ],
+            "wire_admin"
         ]
     },
     "conv_id": "00000000-0000-0000-0000-000100000006"

libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json

@@ -9,17 +9,11 @@
     ],
     "time": "1864-04-12T12:22:43.673Z",
     "action": {
-        "tag": "ConversationActionRemoveMembers",
-        "contents": [
-            {
-                "domain": "golden.example.com",
-                "id": "00000000-0000-0000-0000-000100004007"
-            },
-            {
-                "domain": "golden2.example.com",
-                "id": "00000000-0000-0000-0000-000100005007"
-            }
-        ]
+        "tag": "ConversationActionRemoveMember",
+        "contents": {
+            "domain": "golden.example.com",
+            "id": "00000000-0000-0000-0000-000100004007"
+        }
     },
     "conv_id": "00000000-0000-0000-0000-000100000006"
 }

libs/wire-api/src/Wire/API/Conversation/Action.hs

@@ -18,6 +18,7 @@
 module Wire.API.Conversation.Action
   ( ConversationAction (..),
     conversationActionToEvent,
+    conversationActionTag,
   )
 where
 
@@ -36,11 +37,12 @@ import Wire.API.Util.Aeson (CustomEncoded (..))
 -- | An update to a conversation, including addition and removal of members.
 -- Used to send notifications to users and to remote backends.
 data ConversationAction
-  = ConversationActionAddMembers (NonEmpty (Qualified UserId, RoleName))
-  | ConversationActionRemoveMembers (NonEmpty (Qualified UserId))
+  = ConversationActionAddMembers (NonEmpty (Qualified UserId)) RoleName
+  | ConversationActionRemoveMember (Qualified UserId)
   | ConversationActionRename ConversationRename
   | ConversationActionMessageTimerUpdate ConversationMessageTimerUpdate
-  | ConversationActionMemberUpdate MemberUpdateData
+  | ConversationActionReceiptModeUpdate ConversationReceiptModeUpdate
+  | ConversationActionMemberUpdate (Qualified UserId) OtherMemberUpdate
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform ConversationAction)
   deriving (ToJSON, FromJSON) via (CustomEncoded ConversationAction)
@@ -51,15 +53,28 @@ conversationActionToEvent ::
   Qualified ConvId ->
   ConversationAction ->
   Event
-conversationActionToEvent now quid qcnv (ConversationActionAddMembers newMembers) =
+conversationActionToEvent now quid qcnv (ConversationActionAddMembers newMembers role) =
   Event MemberJoin qcnv quid now $
-    EdMembersJoin $ SimpleMembers (map (uncurry SimpleMember) . toList $ newMembers)
-conversationActionToEvent now quid qcnv (ConversationActionRemoveMembers removedMembers) =
+    EdMembersJoin $ SimpleMembers (map (`SimpleMember` role) (toList newMembers))
+conversationActionToEvent now quid qcnv (ConversationActionRemoveMember removedMember) =
   Event MemberLeave qcnv quid now $
-    EdMembersLeave . QualifiedUserIdList . toList $ removedMembers
+    EdMembersLeave (QualifiedUserIdList [removedMember])
 conversationActionToEvent now quid qcnv (ConversationActionRename rename) =
   Event ConvRename qcnv quid now (EdConvRename rename)
 conversationActionToEvent now quid qcnv (ConversationActionMessageTimerUpdate update) =
   Event ConvMessageTimerUpdate qcnv quid now (EdConvMessageTimerUpdate update)
-conversationActionToEvent now quid qcnv (ConversationActionMemberUpdate update) =
-  Event MemberStateUpdate qcnv quid now (EdMemberUpdate update)
+conversationActionToEvent now quid qcnv (ConversationActionReceiptModeUpdate update) =
+  Event ConvReceiptModeUpdate qcnv quid now (EdConvReceiptModeUpdate update)
+conversationActionToEvent now quid qcnv (ConversationActionMemberUpdate target (OtherMemberUpdate role)) =
+  let update = MemberUpdateData target Nothing Nothing Nothing Nothing Nothing Nothing role
+   in Event MemberStateUpdate qcnv quid now (EdMemberUpdate update)
+
+conversationActionTag :: Qualified UserId -> ConversationAction -> Action
+conversationActionTag _ (ConversationActionAddMembers _ _) = AddConversationMember
+conversationActionTag qusr (ConversationActionRemoveMember victim)
+  | qusr == victim = LeaveConversation
+  | otherwise = RemoveConversationMember
+conversationActionTag _ (ConversationActionRename _) = ModifyConversationName
+conversationActionTag _ (ConversationActionMessageTimerUpdate _) = ModifyConversationMessageTimer
+conversationActionTag _ (ConversationActionReceiptModeUpdate _) = ModifyConversationReceiptMode
+conversationActionTag _ (ConversationActionMemberUpdate _ _) = ModifyOtherConversationMember

libs/wire-api/src/Wire/API/Routes/Public/Galley.hs

@@ -452,7 +452,6 @@ data Api routes = Api
         :- Summary "Update self membership properties (deprecated)"
         :> Description "Use `/conversations/:domain/:conv/self` instead."
         :> CanThrow ConvNotFound
-        :> CanThrow ConvAccessDenied
         :> ZUser
         :> ZConn
         :> "conversations"
@@ -469,7 +468,6 @@ data Api routes = Api
         :- Summary "Update self membership properties"
         :> Description "**Note**: at least one field has to be provided."
         :> CanThrow ConvNotFound
-        :> CanThrow ConvAccessDenied
         :> ZUser
         :> ZConn
         :> "conversations"

services/galley/galley.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 0341ec52f506f40a39b7329c4eeccdccf25bcffc81318f535602bfc17e655f58
+-- hash: 0f1a6ec2e6bf117e21a1b8da6d851d6a5a60cd553c803a079a07aedefbcf0233
 
 name:           galley
 version:        0.83.0
@@ -67,6 +67,7 @@ library
       Galley.Queue
       Galley.Run
       Galley.Types.Clients
+      Galley.Types.UserList
       Galley.Validation
       Main
   other-modules: