Merge pull request #145 from bedatadriven/advanced-user-mangement-vig…

…nette-4.38

Advanced user mangement vignette 4.38

DESCRIPTION

@@ -47,8 +47,11 @@ Suggests:
     markdown,
     withr,
     assertthat,
+    tidyverse,
     tidyr,
     purrr,
+    readr,
+    readxl,
     tinytex
 VignetteBuilder: knitr
 Config/testthat/edition: 3

R/databases.R

@@ -334,6 +334,7 @@ checkUserRole <- function(databaseId, newUser, roleId, roleParameters, roleResou
 #' @param roleId the id of the role to assign to the user.
 #' @param roleParameters a named list containing the role parameter values
 #' @param roleResources an optional list of optional grant-based resources assigned to the user
+#' @param assignment optionally create and pass a \code{\link[activityinfo]{roleAssignment}} like in updateUserRole()
 #'
 #' @details
 #'
@@ -381,9 +382,17 @@ checkUserRole <- function(databaseId, newUser, roleId, roleParameters, roleResou
 #' @export
 addDatabaseUser <- function(databaseId, email, name, locale = NA_character_, roleId,
                             roleParameters = list(),
-                            roleResources = c(databaseId)) {
+                            roleResources = c(databaseId), assignment) {
 
   url <- paste(activityInfoRootUrl(), "resources", "databases", databaseId, "users", sep = "/")
+
+  if (!missing(assignment)) {
+    stopifnot("An assignment must be created with roleAssignment()" = ("activityInfoRoleAssignment" %in% class(assignment)))
+    stopifnot("Either an assignment must be provided or roleId to addDatabaseUser(), but not both." = missing(roleId))
+    roleId = assignment$id
+    roleParameters = assignment$parameters
+    roleResources = assignment$resources
+  }
 
   request <- list(
     email = email,
@@ -631,7 +640,7 @@ updateUserRole <- function(databaseId, userId, assignment) {
 roleAssignment <- function(roleId, roleParameters = list(), roleResources) {
   stopifnot(is.list(roleParameters))
   if (any(is.na(names(roleParameters)))) {
-    stop("roleParameters must be named with each parameter name.")
+    stop("In the `roleParameters` list, each item must be named")
   }
 
   if (length(roleParameters) == 0) {

tests/testthat/test-databases.R

@@ -86,6 +86,32 @@ addTestUsers <- function(database, tree, nUsers = 1, roleId, roleParameters = li
   })
 }
 
+
+addTestUsersWithAssignment <- function(database, tree, nUsers = 1, assignment) {
+  lapply(1:nUsers, function(x) {
+    newUserEmail <- sprintf("test%[email protected]", cuid())
+    newDatabaseUser <- addDatabaseUser(
+      databaseId = database$databaseId, 
+      email = newUserEmail, 
+      name = "Test database user", 
+      locale = "en", 
+      assignment = assignment
+    )
+
+    if (newDatabaseUser$added) {
+      testthat::expect_identical(newDatabaseUser$user$email, newUserEmail)
+      testthat::expect_identical(newDatabaseUser$user$role$id, assignment$id)
+      testthat::expect_true(newDatabaseUser$user$role$resources[[1]] %in% assignment$resources)
+      newDatabaseUser
+    } else {
+      warning("Could not add user with assignment.")
+      NULL
+    }
+  })
+}
+
+
+
 deleteTestUsers <- function(database, returnedUsers) {
   lapply(returnedUsers, function(newDatabaseUser) {
     if (newDatabaseUser$added) {
@@ -340,7 +366,7 @@ testthat::test_that("addRole() and deleteRoles() work", {
 
     testthat::expect_length(addedTree$roles, length(originalTree$roles)+2)
 
-    testthat::test_that("deleteRoles", {
+    testthat::test_that("deleteRoles()", {
       deleteRoles(database$databaseId, roleIds = c(roleId1, roleId2))
 
       deletedTree <- getDatabaseTree(database$databaseId)
@@ -356,16 +382,11 @@ testthat::test_that("addRole() and deleteRoles() work", {
 
 })
 
-testthat::test_that("deleteRole() works", {
-
-})
-
-
 testthat::test_that("updateRole() works for both legacy and new roles", {
   roleId <- "rp"
   roleLabel <- "Reporting partner"
 
-  # create a partner reference form
+  # create a partner reference form with label "Reporting Partners". Label is reused to find the form later on.
   partnerForm <- formSchema(
     databaseId = database$databaseId, 
     label = "Reporting Partners") |>
@@ -579,6 +600,26 @@ testthat::test_that("roleAssignment() works", {
   ))
 })
 
+
+testthat::test_that("addDatabaseUser() accepts a role assignment with parameters and optional grants", {
+  rpRole <- getDatabaseRole(database$databaseId, roleId  = "rp")
+
+  optionalGrants <- as.list(unlist(lapply(rpRole$grants, function(x) {if (x$optional) return(x$resourceId)})))
+
+  partnerFormId = optionalGrants[[1]] # could also use the label "Reporting Partners" if multiple grants are given
+
+  userRoleParam <- list(
+    partner = reference(formId = partnerFormId, recordId = "partner1")
+  )
+
+  addTestUsersWithAssignment(database, tree, nUsers = 1, assignment = roleAssignment(
+    roleId = "rp", 
+    roleParameters = userRoleParam,
+    roleResources = optionalGrants
+  ))
+})
+
+
 testthat::test_that("updateGrant() works", {
   #old method - not tested#
 })