WPB-19716: Batch create Channels and Map them to User Groups (#4790)

Author: blackheaven

cabal.project

@@ -60,6 +60,7 @@ packages:
   , tools/stern/
   , tools/mlsstats/
   , tools/test-stats/
+  , tools/entreprise-provisioning/
 
 tests: True
 benchmarks: True

changelog.d/2-features/WPB-19716

@@ -0,0 +1 @@
+Add `entreprise-provisioning`, a CLI to batch provision various entities, currently, creates and associate channels to existing user-groups.

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

@@ -427,6 +427,7 @@ type UserGroupAPI =
                :> "user-groups"
                :> Capture "gid" UserGroupId
                :> "channels"
+               :> QueryFlag "append_only"
                :> ReqBody '[JSON] UpdateUserGroupChannels
                :> MultiVerb1 'PUT '[JSON] (RespondEmpty 200 "User group channels updated")
            )

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

@@ -41,6 +41,7 @@ data UserGroupStore m a where
   AddUser :: UserGroupId -> UserId -> UserGroupStore m ()
   UpdateUsers :: UserGroupId -> Vector UserId -> UserGroupStore m ()
   RemoveUser :: UserGroupId -> UserId -> UserGroupStore m ()
+  AddUserGroupChannels :: UserGroupId -> Vector ConvId -> UserGroupStore m ()
   UpdateUserGroupChannels :: UserGroupId -> Vector ConvId -> UserGroupStore m ()
   GetUserGroupIdsForUsers :: [UserId] -> UserGroupStore m (Map UserId [UserGroupId])
 

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

@@ -53,7 +53,8 @@ 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
+    AddUserGroupChannels gid convIds -> updateUserGroupChannels True gid convIds
+    UpdateUserGroupChannels gid convIds -> updateUserGroupChannels False gid convIds
     GetUserGroupIdsForUsers uids -> getUserGroupIdsForUsers uids
 
 getUserGroupIdsForUsers :: (UserGroupStorePostgresEffectConstraints r) => [UserId] -> Sem r (Map UserId [UserGroupId])
@@ -413,17 +414,19 @@ removeUser =
 updateUserGroupChannels ::
   forall r.
   (UserGroupStorePostgresEffectConstraints r) =>
+  Bool ->
   UserGroupId ->
   Vector ConvId ->
   Sem r ()
-updateUserGroupChannels gid convIds = do
+updateUserGroupChannels appendOnly 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
+      unless appendOnly $
+        Tx.statement (gid, convIds) deleteStatement
       Tx.statement (gid, convIds) insertStatement
 
     deleteStatement :: Statement (UserGroupId, Vector ConvId) ()

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

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

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

@@ -54,7 +54,8 @@ 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
+  AddChannels performer groupId channelIds -> updateChannels True performer groupId channelIds
+  UpdateChannels performer groupId channelIds -> updateChannels False performer groupId channelIds
 
 data UserGroupSubsystemError
   = UserGroupNotATeamAdmin
@@ -379,19 +380,22 @@ updateChannels ::
     Member NotificationSubsystem r,
     Member GalleyAPIAccess r
   ) =>
+  Bool ->
   UserId ->
   UserGroupId ->
   Vector ConvId ->
   Sem r ()
-updateChannels performer groupId channelIds = do
+updateChannels appendOnly performer groupId channelIds = do
   void $ getUserGroup performer groupId False >>= 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
+  if appendOnly
+    then Store.addUserGroupChannels groupId channelIds
+    else Store.updateUserGroupChannels groupId channelIds
 
   admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins teamId
   pushNotifications

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

@@ -68,7 +68,8 @@ 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
+    AddUserGroupChannels gid convIds -> updateUserGroupChannelsImpl True gid convIds
+    UpdateUserGroupChannels gid convIds -> updateUserGroupChannelsImpl False gid convIds
     GetUserGroupIdsForUsers uids -> getUserGroupIdsForUsersImpl uids
 
 getUserGroupIdsForUsersImpl :: (UserGroupStoreInMemEffectConstraints r) => [UserId] -> Sem r (Map UserId [UserGroupId])
@@ -205,23 +206,24 @@ removeUserImpl gid uid = do
 
 updateUserGroupChannelsImpl ::
   (UserGroupStoreInMemEffectConstraints r, Member (Input (Local ())) r) =>
+  Bool ->
   UserGroupId ->
   Vector ConvId ->
   Sem r ()
-updateUserGroupChannelsImpl gid convIds = do
+updateUserGroupChannelsImpl appendOnly gid convIds = do
   qualifyLocal <- qualifyAs <$> input
-  let f :: Maybe UserGroup -> Maybe UserGroup
-      f Nothing = Nothing
-      f (Just g) =
-        Just
-          ( g
-              { channels = Just $ tUntagged . qualifyLocal <$> convIds,
-                channelsCount = Nothing
-              } ::
-              UserGroup
-          )
-
-  modifyUserGroupsGidOnly gid (Map.alter f)
+  let f :: UserGroup -> UserGroup
+      f g =
+        g
+          { channels =
+              Just $
+                newQualifiedConvIds <> if appendOnly then fromMaybe mempty g.channels else mempty,
+            channelsCount = Just $ length convIds
+          } ::
+          UserGroup
+      newQualifiedConvIds = tUntagged . qualifyLocal <$> convIds
+
+  modifyUserGroupsGidOnly gid (Map.alter $ fmap f)
 
 listUserGroupChannelsImpl ::
   (UserGroupStoreInMemEffectConstraints r) =>

nix/local-haskell-packages.nix

@@ -56,6 +56,7 @@
   repair-handles = hself.callPackage ../tools/db/repair-handles/default.nix { inherit gitignoreSource; };
   service-backfill = hself.callPackage ../tools/db/service-backfill/default.nix { inherit gitignoreSource; };
   team-info = hself.callPackage ../tools/db/team-info/default.nix { inherit gitignoreSource; };
+  entreprise-provisioning = hself.callPackage ../tools/entreprise-provisioning/default.nix { inherit gitignoreSource; };
   mlsstats = hself.callPackage ../tools/mlsstats/default.nix { inherit gitignoreSource; };
   rabbitmq-consumer = hself.callPackage ../tools/rabbitmq-consumer/default.nix { inherit gitignoreSource; };
   rex = hself.callPackage ../tools/rex/default.nix { inherit gitignoreSource; };

services/brig/src/Brig/API/Public.hs

@@ -1728,8 +1728,12 @@ removeUserFromGroup lusr gid mid = lift . liftSem $ UserGroup.removeUser (tUnqua
 updateUserGroupMembers :: (_) => Local UserId -> UserGroupId -> UpdateUserGroupMembers -> Handler r ()
 updateUserGroupMembers lusr gid gupd = lift . liftSem $ UserGroup.updateUsers (tUnqualified lusr) gid gupd.members
 
-updateUserGroupChannels :: (_) => Local UserId -> UserGroupId -> UpdateUserGroupChannels -> Handler r ()
-updateUserGroupChannels lusr gid upd = lift . liftSem $ UserGroup.updateChannels (tUnqualified lusr) gid upd.channels
+updateUserGroupChannels :: (_) => Local UserId -> UserGroupId -> Bool -> UpdateUserGroupChannels -> Handler r ()
+updateUserGroupChannels lusr gid appendOnly upd =
+  lift . liftSem $
+    if appendOnly
+      then UserGroup.addChannels (tUnqualified lusr) gid upd.channels
+      else UserGroup.updateChannels (tUnqualified lusr) gid upd.channels
 
 checkUserGroupNameAvailable :: Local UserId -> CheckUserGroupName -> Handler r UserGroupNameAvailability
 checkUserGroupNameAvailable _ _ = pure $ UserGroupNameAvailability True