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

changelog.d/2-features/WPB-19712

@@ -0,0 +1 @@
+Implement user-groups channels association (`/user-groups/{gid}/channels`).

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

@@ -4,6 +4,7 @@ module Test.UserGroup where
 
 import API.Brig
 import API.Galley
+import API.GalleyInternal (setTeamFeatureLockStatus)
 import Control.Error (lastMay)
 import Notifications (isUserGroupCreatedNotif, isUserGroupUpdatedNotif)
 import SetupHelpers
@@ -390,3 +391,86 @@ testUserGroupRemovalOnDelete = do
   bindResponse (getUserGroup alice gid) $ \resp -> do
     resp.status `shouldMatchInt` 200
     resp.json %. "members" `shouldMatch` [charlieId]
+
+testUserGroupUpdateChannels :: (HasCallStack) => App ()
+testUserGroupUpdateChannels = do
+  (alice, tid, [_bob]) <- createTeam OwnDomain 2
+  setTeamFeatureLockStatus alice tid "channels" "unlocked"
+  let config =
+        object
+          [ "status" .= "enabled",
+            "config"
+              .= object
+                [ "allowed_to_create_channels" .= "team-members",
+                  "allowed_to_open_channels" .= "team-members"
+                ]
+          ]
+  setTeamFeatureConfig alice tid "channels" config >>= assertSuccess
+
+  ug <-
+    createUserGroup alice (object ["name" .= "none", "members" .= (mempty :: [String])])
+      >>= getJSON 200
+  gid <- ug %. "id" & asString
+
+  convId <-
+    postConversation alice (defMLS {team = Just tid, groupConvType = Just "channel"})
+      >>= getJSON 201
+      >>= objConvId
+  withWebSocket alice $ \wsAlice -> do
+    updateUserGroupChannels alice gid [convId.id_] >>= assertSuccess
+
+    notif <- awaitMatch isUserGroupUpdatedNotif wsAlice
+    notif %. "payload.0.user_group.id" `shouldMatch` gid
+
+  -- 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"
+
+testUserGroupUpdateChannelsNonChannel :: (HasCallStack) => App ()
+testUserGroupUpdateChannelsNonChannel = 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_] >>= assertLabel 404 "user-group-channel-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,10 @@ 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
                :> 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/GalleyAPIAccess.hs

@@ -144,5 +144,6 @@ data GalleyAPIAccess m a where
     UserId ->
     GalleyAPIAccess m [EJPDConvInfo]
   GetTeamAdmins :: TeamId -> GalleyAPIAccess m Team.TeamMemberList
+  InternalGetConversation :: ConvId -> GalleyAPIAccess m (Maybe Conversation)
 
 makeSem ''GalleyAPIAccess

libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs

@@ -96,6 +96,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint =
           UnblockConversation lusr mconn qcnv -> unblockConversation v lusr mconn qcnv
           GetEJPDConvInfo uid -> getEJPDConvInfo uid
           GetTeamAdmins tid -> getTeamAdmins tid
+          InternalGetConversation id' -> internalGetConversation id'
 
 getUserLegalholdStatus ::
   ( Member TinyLog r,
@@ -680,3 +681,26 @@ getEJPDConvInfo uid = do
     getReq =
       method GET
         . paths ["i", "user", toByteString' uid, "all-conversations"]
+
+internalGetConversation ::
+  ( Member (Error ParseException) r,
+    Member Rpc r,
+    Member (Input Endpoint) r,
+    Member TinyLog r
+  ) =>
+  ConvId ->
+  Sem r (Maybe Conversation)
+internalGetConversation convId = do
+  debug $
+    remote "galley"
+      . field "conv" (toByteString convId)
+      . msg (val "Getting conversation (internal)")
+  rs <- galleyRequest req
+  case Bilge.statusCode rs of
+    200 -> Just <$> decodeBodyOrThrow "galley" rs
+    _ -> pure Nothing
+  where
+    req =
+      method GET
+        . paths ["i", "conversations", toByteString' convId]
+        . expect [status200, status404]

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

@@ -40,5 +40,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

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

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

@@ -12,6 +12,7 @@ import Imports
 import Polysemy
 import Polysemy.Error
 import Polysemy.Input (Input, input)
+import Wire.API.Conversation qualified as Conversation
 import Wire.API.Error
 import Wire.API.Error.Brig qualified as E
 import Wire.API.Pagination
@@ -23,6 +24,7 @@ import Wire.API.UserEvent
 import Wire.API.UserGroup
 import Wire.API.UserGroup.Pagination
 import Wire.Error
+import Wire.GalleyAPIAccess (GalleyAPIAccess, internalGetConversation)
 import Wire.NotificationSubsystem
 import Wire.TeamSubsystem
 import Wire.UserGroupStore (PaginationState (..), UserGroupPageRequest (..))
@@ -36,7 +38,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
@@ -51,11 +54,13 @@ interpretUserGroupSubsystem = interpret $ \case
   UpdateUsers updater groupId uids -> updateUsers updater groupId uids
   RemoveUser remover groupId removeeId -> removeUser remover groupId removeeId
   RemoveUserFromAllGroups uid tid -> removeUserFromAllGroups uid tid
+  UpdateChannels performer groupId channelIds -> updateChannels performer groupId channelIds
 
 data UserGroupSubsystemError
   = UserGroupNotATeamAdmin
   | UserGroupMemberIsNotInTheSameTeam
   | UserGroupNotFound
+  | UserGroupChannelNotFound
   deriving (Show, Eq)
 
 userGroupSubsystemErrorToHttpError :: UserGroupSubsystemError -> HttpError
@@ -64,6 +69,7 @@ userGroupSubsystemErrorToHttpError =
     UserGroupNotATeamAdmin -> errorToWai @E.UserGroupNotATeamAdmin
     UserGroupMemberIsNotInTheSameTeam -> errorToWai @E.UserGroupMemberIsNotInTheSameTeam
     UserGroupNotFound -> errorToWai @E.UserGroupNotFound
+    UserGroupChannelNotFound -> errorToWai @E.UserGroupChannelNotFound
 
 createUserGroup ::
   ( Member UserSubsystem r,
@@ -364,3 +370,30 @@ removeUserFromAllGroups uid tid = do
             searchString = Nothing,
             includeMemberCount = False
           }
+
+updateChannels ::
+  ( Member UserSubsystem r,
+    Member Store.UserGroupStore r,
+    Member (Error UserGroupSubsystemError) r,
+    Member TeamSubsystem r,
+    Member NotificationSubsystem 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
+  for_ channelIds $ \channelId -> do
+    conv <- internalGetConversation channelId >>= note UserGroupChannelNotFound
+    let meta = conv.metadata
+    unless (meta.cnvmTeam == Just teamId && meta.cnvmGroupConvType == Just Conversation.Channel) $
+      throw UserGroupChannelNotFound
+  Store.updateUserGroupChannels groupId channelIds
+
+  admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins teamId
+  pushNotifications
+    [ mkEvent performer (UserGroupUpdated groupId) admins
+    ]

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

@@ -49,6 +49,7 @@ miniGalleyAPIAccess teams configs = interpret $ \case
   GetEJPDConvInfo _ -> error "GetEJPDConvInfo not implemented in miniGalleyAPIAccess"
   GetTeamAdmins tid -> pure $ newTeamMemberList (maybe [] (filter (\tm -> isAdminOrOwner (tm ^. permissions))) $ Map.lookup tid teams) ListComplete
   SelectTeamMemberInfos tid uids -> pure $ selectTeamMemberInfosImpl teams tid uids
+  InternalGetConversation _ -> error "GetConv not implemented in InternalGetConversation"
 
 -- this is called but the result is not needed in unit tests
 selectTeamMemberInfosImpl :: Map TeamId [TeamMember] -> TeamId -> [UserId] -> TeamMemberInfoList