WPB-19712: Allow team admin to update the channels to user-group association

Author: blackheaven

integration/test/API/Brig.hs

@@ -1061,6 +1061,11 @@ getUserGroup user gid = do
   req <- baseRequest user Brig Versioned $ joinHttpPath ["user-groups", gid]
   submit "GET" req
 
+updateUserGroupChannels :: (MakesValue user) => user -> String -> [String] -> App Response
+updateUserGroupChannels user gid convIds = do
+  req <- baseRequest user Brig Versioned $ joinHttpPath ["user-groups", gid, "channels"]
+  submit "PUT" $ req & addJSONObject ["channels" .= convIds]
+
 data GetUserGroupsArgs = GetUserGroupsArgs
   { q :: Maybe String,
     sortByKeys :: Maybe String,

integration/test/Test/UserGroup.hs

@@ -373,3 +373,56 @@ testUserGroupMembersCount = do
     resp.status `shouldMatchInt` 200
     resp.json %. "page.0.membersCount" `shouldMatchInt` 2
     resp.json %. "total" `shouldMatchInt` 1
+
+testUserGroupUpdateChannels :: (HasCallStack) => App ()
+testUserGroupUpdateChannels = do
+  (alice, tid, [_bob]) <- createTeam OwnDomain 2
+
+  ug <-
+    createUserGroup alice (object ["name" .= "none", "members" .= (mempty :: [String])])
+      >>= getJSON 200
+  gid <- ug %. "id" & asString
+
+  convId <-
+    postConversation alice (defProteus {team = Just tid})
+      >>= getJSON 201
+      >>= objConvId
+  updateUserGroupChannels alice gid [convId.id_] >>= assertSuccess
+
+  -- bobId <- asString $ bob %. "id"
+  bindResponse (getUserGroup alice gid) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+
+-- FUTUREWORK: check the actual associated channels
+--  resp.json %. "members" `shouldMatch` [bobId]
+
+testUserGroupUpdateChannelsNonAdmin :: (HasCallStack) => App ()
+testUserGroupUpdateChannelsNonAdmin = do
+  (alice, tid, [bob]) <- createTeam OwnDomain 2
+
+  ug <-
+    createUserGroup alice (object ["name" .= "none", "members" .= (mempty :: [String])])
+      >>= getJSON 200
+  gid <- ug %. "id" & asString
+
+  convId <-
+    postConversation alice (defProteus {team = Just tid})
+      >>= getJSON 201
+      >>= objConvId
+  updateUserGroupChannels bob gid [convId.id_] >>= assertLabel 404 "user-group-not-found"
+
+testUserGroupUpdateChannelsNonExisting :: (HasCallStack) => App ()
+testUserGroupUpdateChannelsNonExisting = do
+  (alice, tid, _) <- createTeam OwnDomain 1
+  (bob, _, _) <- createTeam OwnDomain 1
+
+  ug <-
+    createUserGroup alice (object ["name" .= "none", "members" .= (mempty :: [String])])
+      >>= getJSON 200
+  gid <- ug %. "id" & asString
+
+  convId <-
+    postConversation alice (defProteus {team = Just tid})
+      >>= getJSON 201
+      >>= objConvId
+  updateUserGroupChannels bob gid [convId.id_] >>= assertLabel 404 "user-group-not-found"

libs/wire-api/src/Wire/API/Error/Brig.hs

@@ -118,6 +118,7 @@ data BrigError
   | UserGroupNotFound
   | UserGroupNotATeamAdmin
   | UserGroupMemberIsNotInTheSameTeam
+  | UserGroupChannelNotFound
   | DuplicateEntry
   | MLSInvalidLeafNodeSignature
 
@@ -351,6 +352,8 @@ type instance MapError 'UserGroupNotFound = 'StaticError 404 "user-group-not-fou
 
 type instance MapError 'UserGroupNotATeamAdmin = 'StaticError 403 "user-group-write-forbidden" "Only team admins can create, update, or delete user groups."
 
+type instance MapError 'UserGroupChannelNotFound = 'StaticError 404 "user-group-channel-not-found" "Specified Channel does not exists or does not belongs to the team"
+
 type instance MapError 'UserGroupMemberIsNotInTheSameTeam = 'StaticError 400 "user-group-invalid" "Only team members of the same team can be added to a user group."
 
 type instance MapError 'DuplicateEntry = 'StaticError 409 "duplicate-entry" "Entry already exists"

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

@@ -418,8 +418,11 @@ type UserGroupAPI =
            )
     :<|> Named
            "update-user-group-channels"
-           ( Summary "[STUB] Update user group channels. Replaces the channels with the given list."
+           ( Summary "Replaces the channels with the given list."
                :> From 'V12
+               :> CanThrow 'UserGroupNotFound
+               :> CanThrow 'UserGroupNotATeamAdmin
+               :> CanThrow 'UserGroupNotFound
                :> ZLocalUser
                :> "user-groups"
                :> Capture "gid" UserGroupId

libs/wire-subsystems/postgres-migrations/202509190851023-user_group_conversations_create_table.sql

@@ -0,0 +1,8 @@
+CREATE TABLE public.user_group_channel (
+    user_group_id uuid NOT NULL,
+    conv_id uuid NOT NULL,
+    PRIMARY KEY (user_group_id, conv_id)
+);
+
+ALTER TABLE ONLY public.user_group_channel
+    ADD CONSTRAINT fk_user_group_channel FOREIGN KEY (user_group_id) REFERENCES public.user_group(id) ON DELETE CASCADE;

libs/wire-subsystems/src/Wire/UserGroupStore.hs

@@ -37,5 +37,6 @@ data UserGroupStore m a where
   AddUser :: UserGroupId -> UserId -> UserGroupStore m ()
   UpdateUsers :: UserGroupId -> Vector UserId -> UserGroupStore m ()
   RemoveUser :: UserGroupId -> UserId -> UserGroupStore m ()
+  UpdateUserGroupChannels :: UserGroupId -> Vector ConvId -> UserGroupStore m ()
 
 makeSem ''UserGroupStore

libs/wire-subsystems/src/Wire/UserGroupStore/Postgres.hs

@@ -29,7 +29,7 @@ import Polysemy.Error (Error, throw)
 import Polysemy.Input
 import Wire.API.Pagination
 import Wire.API.User.Profile
-import Wire.API.UserGroup
+import Wire.API.UserGroup hiding (UpdateUserGroupChannels)
 import Wire.API.UserGroup.Pagination
 import Wire.UserGroupStore (PaginationState (..), UserGroupPageRequest (..), UserGroupStore (..), toSortBy)
 
@@ -53,6 +53,7 @@ interpretUserGroupStoreToPostgres =
     AddUser gid uid -> addUser gid uid
     UpdateUsers gid uids -> updateUsers gid uids
     RemoveUser gid uid -> removeUser gid uid
+    UpdateUserGroupChannels gid convIds -> updateUserGroupChannels gid convIds
 
 updateUsers :: (UserGroupStorePostgresEffectConstraints r) => UserGroupId -> Vector UserId -> Sem r ()
 updateUsers gid uids = do
@@ -408,6 +409,38 @@ removeUser =
       delete from user_group_member where user_group_id = ($1 :: uuid) and user_id = ($2 :: uuid)
       |]
 
+updateUserGroupChannels ::
+  forall r.
+  (UserGroupStorePostgresEffectConstraints r) =>
+  UserGroupId ->
+  Vector ConvId ->
+  Sem r ()
+updateUserGroupChannels gid convIds = do
+  pool <- input
+  eitherErrorOrUnit <- liftIO $ use pool session
+  either throw pure eitherErrorOrUnit
+  where
+    session :: Session ()
+    session = TxSessions.transaction TxSessions.Serializable TxSessions.Write $ do
+      Tx.statement (gid, convIds) deleteStatement
+      Tx.statement (gid, convIds) insertStatement
+
+    deleteStatement :: Statement (UserGroupId, Vector ConvId) ()
+    deleteStatement =
+      lmap
+        (bimap toUUID (fmap toUUID))
+        $ [resultlessStatement|
+          delete from user_group_channel where user_group_id = ($1 :: uuid) and conv_id not in (SELECT unnest($2 :: uuid[]))
+          |]
+
+    insertStatement :: Statement (UserGroupId, Vector ConvId) ()
+    insertStatement =
+      lmap (bimap (fmap (.toUUID)) (fmap (.toUUID)) . uncurry toRelationTable) $
+        [resultlessStatement|
+          insert into user_group_channel (user_group_id, conv_id)  select * from unnest ($1 :: uuid[], $2 :: uuid[])
+          on conflict (user_group_id, conv_id) do nothing
+          |]
+
 crudUser ::
   forall r.
   (UserGroupStorePostgresEffectConstraints r) =>

libs/wire-subsystems/src/Wire/UserGroupSubsystem.hs

@@ -32,5 +32,6 @@ data UserGroupSubsystem m a where
   AddUsers :: UserId -> UserGroupId -> Vector UserId -> UserGroupSubsystem m ()
   UpdateUsers :: UserId -> UserGroupId -> Vector UserId -> UserGroupSubsystem m ()
   RemoveUser :: UserId -> UserGroupId -> UserId -> UserGroupSubsystem m ()
+  UpdateChannels :: UserId -> UserGroupId -> Vector ConvId -> UserGroupSubsystem m ()
 
 makeSem ''UserGroupSubsystem

libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs

@@ -23,6 +23,7 @@ import Wire.API.UserEvent
 import Wire.API.UserGroup
 import Wire.API.UserGroup.Pagination
 import Wire.Error
+import Wire.GalleyAPIAccess (GalleyAPIAccess, getTeamConv)
 import Wire.NotificationSubsystem
 import Wire.TeamSubsystem
 import Wire.UserGroupStore (PaginationState (..), UserGroupPageRequest (..))
@@ -36,7 +37,8 @@ interpretUserGroupSubsystem ::
     Member Store.UserGroupStore r,
     Member (Input (Local ())) r,
     Member NotificationSubsystem r,
-    Member TeamSubsystem r
+    Member TeamSubsystem r,
+    Member GalleyAPIAccess r
   ) =>
   InterpreterFor UserGroupSubsystem r
 interpretUserGroupSubsystem = interpret $ \case
@@ -50,11 +52,13 @@ interpretUserGroupSubsystem = interpret $ \case
   AddUsers adder groupId addeeIds -> addUsers adder groupId addeeIds
   UpdateUsers updater groupId uids -> updateUsers updater groupId uids
   RemoveUser remover groupId removeeId -> removeUser remover groupId removeeId
+  UpdateChannels performer groupId channelIds -> updateChannels performer groupId channelIds
 
 data UserGroupSubsystemError
   = UserGroupNotATeamAdmin
   | UserGroupMemberIsNotInTheSameTeam
   | UserGroupNotFound
+  | UserGroupChannelNotFound
   deriving (Show, Eq)
 
 userGroupSubsystemErrorToHttpError :: UserGroupSubsystemError -> HttpError
@@ -63,6 +67,7 @@ userGroupSubsystemErrorToHttpError =
     UserGroupNotATeamAdmin -> errorToWai @E.UserGroupNotATeamAdmin
     UserGroupMemberIsNotInTheSameTeam -> errorToWai @E.UserGroupMemberIsNotInTheSameTeam
     UserGroupNotFound -> errorToWai @E.UserGroupNotFound
+    UserGroupChannelNotFound -> errorToWai @E.UserGroupChannelNotFound
 
 createUserGroup ::
   ( Member UserSubsystem r,
@@ -328,3 +333,20 @@ removeUser remover groupId removeeId = do
     pushNotifications
       [ mkEvent remover (UserGroupUpdated groupId) admins
       ]
+
+updateChannels ::
+  ( Member UserSubsystem r,
+    Member Store.UserGroupStore r,
+    Member (Error UserGroupSubsystemError) r,
+    Member TeamSubsystem r,
+    Member GalleyAPIAccess r
+  ) =>
+  UserId ->
+  UserGroupId ->
+  Vector ConvId ->
+  Sem r ()
+updateChannels performer groupId channelIds = do
+  void $ getUserGroup performer groupId >>= note UserGroupNotFound
+  teamId <- getTeamAsAdmin performer >>= note UserGroupNotATeamAdmin
+  traverse_ (getTeamConv performer teamId >=> note UserGroupChannelNotFound) channelIds
+  Store.updateUserGroupChannels groupId channelIds

libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserGroupStore.hs

@@ -7,9 +7,11 @@
 module Wire.MockInterpreters.UserGroupStore where
 
 import Control.Lens ((%~), _2)
+import Data.Domain (Domain (Domain))
 import Data.Id
 import Data.Json.Util
 import Data.Map qualified as Map
+import Data.Qualified (Qualified (Qualified))
 import Data.Text qualified as T
 import Data.Time.Clock
 import Data.Vector (Vector, fromList)
@@ -21,7 +23,7 @@ import Polysemy.State
 import System.Random (StdGen, mkStdGen)
 import Wire.API.Pagination
 import Wire.API.User
-import Wire.API.UserGroup
+import Wire.API.UserGroup hiding (UpdateUserGroupChannels)
 import Wire.API.UserGroup.Pagination
 import Wire.MockInterpreters.Now
 import Wire.MockInterpreters.Random
@@ -62,6 +64,7 @@ userGroupStoreTestInterpreter =
     AddUser gid uid -> addUserImpl gid uid
     UpdateUsers gid uids -> updateUsersImpl gid uids
     RemoveUser gid uid -> removeUserImpl gid uid
+    UpdateUserGroupChannels gid convIds -> updateUserGroupChannelsImpl gid convIds
 
 updateUsersImpl :: (UserGroupStoreInMemEffectConstraints r) => UserGroupId -> Vector UserId -> Sem r ()
 updateUsersImpl gid uids = do
@@ -179,6 +182,25 @@ removeUserImpl gid uid = do
 
   modifyUserGroupsGidOnly gid (Map.alter f)
 
+updateUserGroupChannelsImpl ::
+  (UserGroupStoreInMemEffectConstraints r) =>
+  UserGroupId ->
+  Vector ConvId ->
+  Sem r ()
+updateUserGroupChannelsImpl gid convIds = do
+  let f :: Maybe UserGroup -> Maybe UserGroup
+      f Nothing = Nothing
+      f (Just g) =
+        Just
+          ( g
+              { channels = Identity $ Just $ flip Qualified (Domain "<local>") <$> convIds,
+                channelsCount = Just $ length convIds
+              } ::
+              UserGroup
+          )
+
+  modifyUserGroupsGidOnly gid (Map.alter f)
+
 ----------------------------------------------------------------------
 
 modifyUserGroupsGidOnly ::