wip

Author: smatting

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

@@ -71,6 +71,7 @@ module Wire.API.Conversation
     ConversationMessageTimerUpdate (..),
     ConversationJoin (..),
     ConversationLeave (..),
+    ConversationRemoveMembers (..),
     ConversationMemberUpdate (..),
     ConversationDelete (..),
 
@@ -896,10 +897,25 @@ instance ToSchema ConversationLeave where
   schema =
     objectWithDocModifier
       "ConversationLeave"
-      (description ?~ "The action of some users leaving a conversation")
+      (description ?~ "The action of some users leaving a conversation on their own")
       $ ConversationLeave
         <$> clUsers .= field "users" (nonEmptyArray schema)
 
+data ConversationRemoveMembers = ConversationRemoveMembers
+  { crmTargets :: NonEmpty (Qualified UserId)
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via (GenericUniform ConversationRemoveMembers)
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema ConversationRemoveMembers
+
+instance ToSchema ConversationRemoveMembers where
+  schema =
+    objectWithDocModifier
+      "ConversationRemoveMembers"
+      (description ?~ "The action of some users being removed from a conversation")
+      $ ConversationRemoveMembers
+        <$> crmTargets .= field "targets" (nonEmptyArray schema)
+
 data ConversationMemberUpdate = ConversationMemberUpdate
   { cmuTarget :: Qualified UserId,
     cmuUpdate :: OtherMemberUpdate

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

@@ -23,13 +23,13 @@ module Wire.API.Conversation.Action
     SConversationActionTag (..),
     SomeConversationAction (..),
     conversationActionToEvent,
-    conversationActionPermission
+    conversationActionPermission,
   )
 where
 
 import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.:), (.=))
 import Data.Id
-import Data.Qualified ( Qualified )
+import Data.Qualified (Qualified)
 import Data.Schema (ToSchema, element, enum, schema, schemaParseJSON, schemaToJSON)
 import Data.Singletons (Sing, SomeSing (SomeSing), fromSing, toSing)
 import Data.Singletons.TH (genSingletons, sCases)
@@ -44,6 +44,7 @@ import Wire.API.Event.Conversation
 data ConversationActionTag
   = ConversationJoinTag
   | ConversationLeaveTag
+  | ConversationRemoveMembersTag
   | ConversationMemberUpdateTag
   | ConversationDeleteTag
   | ConversationRenameTag
@@ -61,6 +62,7 @@ instance ToSchema ConversationActionTag where
       mconcat
         [ element "ConversationJoinTag" ConversationJoinTag,
           element "ConversationLeaveTag" ConversationLeaveTag,
+          element "ConversationRemoveMembersTag" ConversationRemoveMembersTag,
           element "ConversationMemberUpdateTag" ConversationMemberUpdateTag,
           element "ConversationDeleteTag" ConversationDeleteTag,
           element "ConversationRenameTag" ConversationRenameTag,
@@ -86,6 +88,7 @@ type family ConversationAction (tag :: ConversationActionTag) :: * where
   ConversationAction 'ConversationMessageTimerUpdateTag = ConversationMessageTimerUpdate
   ConversationAction 'ConversationReceiptModeUpdateTag = ConversationReceiptModeUpdate
   ConversationAction 'ConversationAccessDataTag = ConversationAccessData
+  ConversationAction 'ConversationRemoveMembersTag = ConversationRemoveMembers
 
 data SomeConversationAction where
   SomeConversationAction :: Sing tag -> ConversationAction tag -> SomeConversationAction
@@ -98,14 +101,23 @@ instance Eq SomeConversationAction where
   (SomeConversationAction tag1 action1) == (SomeConversationAction tag2 action2) =
     case (tag1, tag2) of
       (SConversationJoinTag, SConversationJoinTag) -> action1 == action2
+      (SConversationJoinTag, _) -> False
       (SConversationLeaveTag, SConversationLeaveTag) -> action1 == action2
+      (SConversationLeaveTag, _) -> False
       (SConversationMemberUpdateTag, SConversationMemberUpdateTag) -> action1 == action2
+      (SConversationMemberUpdateTag, _) -> False
       (SConversationDeleteTag, SConversationDeleteTag) -> action1 == action2
+      (SConversationDeleteTag, _) -> False
       (SConversationRenameTag, SConversationRenameTag) -> action1 == action2
+      (SConversationRenameTag, _) -> False
       (SConversationMessageTimerUpdateTag, SConversationMessageTimerUpdateTag) -> action1 == action2
+      (SConversationMessageTimerUpdateTag, _) -> False
       (SConversationReceiptModeUpdateTag, SConversationReceiptModeUpdateTag) -> action1 == action2
+      (SConversationReceiptModeUpdateTag, _) -> False
       (SConversationAccessDataTag, SConversationAccessDataTag) -> action1 == action2
-      (_, _) -> False
+      (SConversationAccessDataTag, _) -> False
+      (SConversationRemoveMembersTag, SConversationRemoveMembersTag) -> action1 == action2
+      (SConversationRemoveMembersTag, _) -> False
 
 instance ToJSON SomeConversationAction where
   toJSON (SomeConversationAction sb action) =
@@ -131,6 +143,7 @@ instance Arbitrary SomeConversationAction where
 conversationActionPermission :: ConversationActionTag -> Action
 conversationActionPermission ConversationJoinTag = AddConversationMember
 conversationActionPermission ConversationLeaveTag = LeaveConversation
+conversationActionPermission ConversationRemoveMembersTag = RemoveConversationMember
 conversationActionPermission ConversationMemberUpdateTag = ModifyOtherConversationMember
 conversationActionPermission ConversationDeleteTag = DeleteConversation
 conversationActionPermission ConversationRenameTag = ModifyConversationName
@@ -153,9 +166,13 @@ conversationActionToEvent tag now quid qcnv action =
        in Event MemberJoin qcnv quid now $
             EdMembersJoin $ SimpleMembers (map (`SimpleMember` role) (toList newMembers))
     SConversationLeaveTag ->
-      let ConversationLeave removedMembers = action
+      let ConversationLeave leavingMembers = action
        in Event MemberLeave qcnv quid now $
-            EdMembersLeave (QualifiedUserIdList (toList removedMembers))
+            EdMembersLeave (QualifiedUserIdList (toList leavingMembers))
+    SConversationRemoveMembersTag ->
+      let ConversationRemoveMembers targets = action
+       in Event MemberLeave qcnv quid now $
+            EdMembersLeave (QualifiedUserIdList (toList targets))
     SConversationMemberUpdateTag ->
       let ConversationMemberUpdate target (OtherMemberUpdate role) = action
           update = MemberUpdateData target Nothing Nothing Nothing Nothing Nothing Nothing role

services/galley/src/Galley/API/Action.hs

@@ -79,10 +79,11 @@ import Polysemy.Input
 import qualified Polysemy.TinyLog as P
 import qualified System.Logger as Log
 import Wire.API.Conversation hiding (Conversation, Member)
-import Wire.API.Conversation.Action hiding (conversationActionToEvent)
+import Wire.API.Conversation.Action
 import Wire.API.Conversation.Role
 import Wire.API.ErrorDescription
 import Wire.API.Event.Conversation hiding (Conversation)
+import Wire.API.Federation.API (Component (Galley), fedClient)
 import Wire.API.Federation.API.Galley
 import Wire.API.Federation.Error
 import Wire.API.Team.LegalHold
@@ -104,65 +105,6 @@ data NoChanges = NoChanges
 --   deriving (Arbitrary) via (GenericUniform ConversationAction)
 --   deriving (ToJSON, FromJSON) via (CustomEncoded ConversationAction)
 
--- conversationActionToEvent ::
---   UTCTime ->
---   Qualified UserId ->
---   Qualified ConvId ->
---   ConversationAction ->
---   Event
--- conversationActionToEvent now quid qcnv (ConversationActionAddMembers newMembers role) =
---   Event MemberJoin qcnv quid now $
---     EdMembersJoin $ SimpleMembers (map (`SimpleMember` role) (toList newMembers))
--- conversationActionToEvent now quid qcnv (ConversationActionRemoveMembers removedMembers) =
---   Event MemberLeave qcnv quid now $
---     EdMembersLeave (QualifiedUserIdList (toList removedMembers))
--- 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 (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)
--- conversationActionToEvent now quid qcnv (ConversationActionAccessUpdate update) =
---   Event ConvAccessUpdate qcnv quid now (EdConvAccessUpdate update)
--- conversationActionToEvent now quid qcnv ConversationActionDelete =
---   Event ConvDelete qcnv quid now EdConvDelete
-
-conversationActionToEvent ::
-  forall tag.
-  Sing tag ->
-  UTCTime ->
-  Qualified UserId ->
-  Qualified ConvId ->
-  ConversationAction tag ->
-  Event
-conversationActionToEvent tag now quid qcnv action =
-  case tag of
-    SConversationJoinTag ->
-      let ConversationJoin newMembers role = action
-       in Event MemberJoin qcnv quid now $
-            EdMembersJoin $ SimpleMembers (map (`SimpleMember` role) (toList newMembers))
-    SConversationLeaveTag ->
-      let ConversationLeave removedMembers = action
-       in Event MemberLeave qcnv quid now $
-            EdMembersLeave (QualifiedUserIdList (toList removedMembers))
-    SConversationMemberUpdateTag ->
-      let ConversationMemberUpdate target (OtherMemberUpdate role) = action
-          update = MemberUpdateData target Nothing Nothing Nothing Nothing Nothing Nothing role
-       in Event MemberStateUpdate qcnv quid now (EdMemberUpdate update)
-    SConversationDeleteTag ->
-      Event ConvDelete qcnv quid now EdConvDelete
-    SConversationRenameTag ->
-      Event ConvRename qcnv quid now $ EdConvRename action
-    SConversationMessageTimerUpdateTag ->
-      Event ConvMessageTimerUpdate qcnv quid now (EdConvMessageTimerUpdate action)
-    SConversationReceiptModeUpdateTag ->
-      Event ConvReceiptModeUpdate qcnv quid now (EdConvReceiptModeUpdate action)
-    SConversationAccessDataTag ->
-      Event ConvAccessUpdate qcnv quid now (EdConvAccessUpdate action)
-
 type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Constraint where
   HasConversationActionEffects 'ConversationJoinTag r =
     Members
@@ -187,6 +129,8 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con
       r
   HasConversationActionEffects 'ConversationLeaveTag r =
     (Members '[MemberStore, Error NoChanges] r)
+  HasConversationActionEffects 'ConversationRemoveMembersTag r =
+    (Members '[MemberStore, Error NoChanges] r)
   HasConversationActionEffects 'ConversationMemberUpdateTag r =
     (Members '[MemberStore, Error ConversationError] r)
   HasConversationActionEffects 'ConversationDeleteTag r =
@@ -288,6 +232,11 @@ performAction origUser lcnv cnv action =
       when (null presentVictims) noChanges
       E.deleteMembers (convId cnv) (toUserList lcnv presentVictims)
       pure (mempty, action) -- FUTUREWORK: should we return the filtered action here?
+    SConversationRemoveMembersTag -> do
+      let presentVictims = filter (isConvMember lcnv cnv) (toList (crmTargets action))
+      when (null presentVictims) noChanges
+      E.deleteMembers (convId cnv) (toUserList lcnv presentVictims)
+      pure (mempty, action) -- FUTUREWORK: should we return the filtered action here?
     SConversationMemberUpdateTag -> do
       void $ ensureOtherMember lcnv (cmuTarget action) cnv
       E.setOtherMember lcnv (cmuTarget action) (cmuUpdate action)
@@ -315,31 +264,6 @@ performAction origUser lcnv cnv action =
       (bm, act) <- performConversationAccessData origUser lcnv cnv action
       pure (bm, act)
 
--- -- | An update to a conversation, including addition and removal of members.
--- -- Used to send notifications to users and to remote backends.
--- class IsConversationAction a where
---   conversationAction :: a -> ConversationAction
---   ensureAllowed ::
---     (IsConvMember mem) =>
---     Local x ->
---     a ->
---     Conversation ->
---     mem ->
---     Sem r ()
---   ensureAllowed _ _ _ _ = pure ()
-
---   conversationActionPermission :: Action
-
---   conversationActionTag' :: ConversationActionTag
---   performAction ::
---     ( Members '[ConversationStore, Error NoChanges] r
---     ) =>
---     Qualified UserId ->
---     Local ConvId ->
---     Conversation ->
---     a ->
---     Sem r (BotsAndMembers, a)
-
 performConversationJoin ::
   (HasConversationActionEffects 'ConversationJoinTag r) =>
   Qualified UserId ->
@@ -498,7 +422,7 @@ performConversationAccessData qusr lcnv conv action = do
     void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do
       let rAction = ConversationLeave usersToRemove
       void . runError @NoChanges $ performAction @'ConversationLeaveTag qusr lcnv conv rAction
-      notifyConversationAction @'ConversationLeaveTag qusr Nothing lcnv bmToNotify rAction
+      notifyConversationAction (sing @'ConversationLeaveTag) qusr Nothing lcnv bmToNotify rAction
   pure (mempty, action)
   where
     maybeRemoveBots :: Member BrigAccess r => BotsAndMembers -> Sem r BotsAndMembers
@@ -568,7 +492,8 @@ updateLocalConversationWithLocalUser lcnv lusr con action = do
   -- perform action
   (extraTargets, action') <- performAction @tag (qUntagged lusr) lcnv conv action
 
-  notifyConversationAction @tag
+  notifyConversationAction
+    (sing @tag)
     (qUntagged lusr)
     con
     lcnv
@@ -616,7 +541,8 @@ updateLocalConversationWithRemoteUser _tag lcnv rusr action = do
       remotesOtherDomain = remotes Set.\\ remotesUserDomain
 
   void $
-    notifyConversationAction @tag
+    notifyConversationAction
+      (sing @tag)
       (qUntagged rusr)
       Nothing
       lcnv
@@ -678,20 +604,20 @@ notifyConversationAction ::
   forall tag r.
   (SingI tag) =>
   Members '[FederatorAccess, ExternalAccess, GundeckAccess, Input UTCTime] r =>
+  Sing tag ->
   Qualified UserId ->
   Maybe ConnId ->
   Local ConvId ->
   BotsAndMembers ->
   ConversationAction (tag :: ConversationActionTag) ->
   Sem r Event
-notifyConversationAction quid con lcnv targets action = do
+notifyConversationAction tag quid con lcnv targets action = do
   now <- input
   let e = conversationActionToEvent (sing @tag) now quid (qUntagged lcnv) action
 
-  -- TODO: uncomment this!
-  -- E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids ->
-  --   fedClient @'Galley @"on-conversation-updated" $
-  --     ConversationUpdate now quid (tUnqualified lcnv) (tUnqualified ruids) action
+  E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids ->
+    fedClient @'Galley @"on-conversation-updated" $
+      ConversationUpdate now quid (tUnqualified lcnv) (tUnqualified ruids) (SomeConversationAction tag action)
 
   -- notify local participants and bots
   pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) $> e