Enable setting/getting of asset-level permissions in the latest gobbler.

R/fetchPermissions.R

@@ -4,10 +4,12 @@
 #' This will call the REST API if the caller is not on the same filesystem as the registry.
 #' 
 #' @param project String containing the project name.
+#' @param asset String containing the asset name.
+#' If specified, permissions are retrieved for the asset rather than the entire project.
 #' @inheritParams listProjects
 #'
-#' @return List containing the permissions for this project.
-#' This has the following elements:
+#' @return List containing the permissions for this project/asset.
+#' For project-level permissions, the list has the following elements:
 #' \itemize{
 #' \item \code{owners}, a character vector containing the user IDs of owners of this project.
 #' \item \code{uploaders}, a list of lists specifying the users or organizations who are authorzied to upload to this project.
@@ -27,6 +29,7 @@
 #' In this mode, any user can create any number of new assets in this project.
 #' Each user can also upload new versions of any asset that they created in this mode.
 #' }
+#' For asset-level permissions, the list has \code{owners} and \code{uploaders} to describe the owners and uploaders, respectively, for the specified \code{asset}.
 #'
 #' @author Aaron Lun
 #'
@@ -50,17 +53,36 @@
 #' @export
 #' @importFrom jsonlite fromJSON
 #' @import httr2
-fetchPermissions <- function(project, registry, url, forceRemote=FALSE) {
-    if (file.exists(registry) && !forceRemote) {
-        content <- file.path(registry, project, "..permissions")
+fetchPermissions <- function(project, registry, url, asset=NULL, forceRemote=FALSE) {
+    use.registry <- (file.exists(registry) && !forceRemote)
+
+    if (is.null(asset)) {
+        if (use.registry) {
+            content <- file.path(registry, project, "..permissions")
+        } else {
+            req <- request(paste0(url, "/fetch/", paste(project, "..permissions", sep="/")))
+            resp <- req_perform(req)
+            content <- resp_body_string(resp)
+        }
+        perms <- fromJSON(content, simplifyVector=FALSE)
+
     } else {
-        req <- request(paste0(url, "/fetch/", paste(project, "..permissions", sep="/")))
-        resp <- req_perform(req)
-        content <- resp_body_string(resp)
+        perms <- list(owners=list(), uploaders=list())
+        if (use.registry) {
+            content <- file.path(registry, project, asset, "..permissions")
+            if (file.exists(content)) {
+                perms <- fromJSON(content, simplifyVector=FALSE)
+            }
+        } else {
+            perms <- tryCatch({
+                req <- request(paste0(url, "/fetch/", paste(project, asset, "..permissions", sep="/")))
+                resp <- req_perform(req)
+                content <- resp_body_string(resp)
+                fromJSON(content, simplifyVector=FALSE)
+            }, httr2_http_404 = function(cnd) perms)
+        }
     }
 
-    perms <- fromJSON(content, simplifyVector=FALSE)
-
     # Converting everything to POSIX dates.
     for (i in seq_along(perms$uploaders)) {
         current <- perms$uploaders[[i]]

R/setPermissions.R

@@ -3,14 +3,17 @@
 #' Set the owner and uploader permissions for a project.
 #'
 #' @param project String containing the project name.
-#' @param owners Character vector containing the user IDs for owners of this project.
+#' @param asset String containing the asset name.
+#' If specified, permissions are set on the asset rather than the entire project.
+#' @param owners Character vector containing the user IDs for owners of this project/asset.
 #' If \code{NULL}, no change is made to the existing owners of the project.
-#' @param uploaders List specifying the authorized uploaders for this project.
+#' @param uploaders List specifying the authorized uploaders for this project/asset.
 #' See the \code{uploaders} field in the \code{\link{fetchPermissions}} return value for the expected format. 
-#' If \code{NULL}, no change is made to the existing uploaders of the project.
+#' If \code{NULL}, no change is made to the existing uploaders of the project/asset.
 #' @param globalWrite Logical scalar indicating whether global writes should be enabled (see \code{\link{fetchPermissions}} for details).
 #' If \code{NULL}, no change is made to the global write status of the project.
-#' @param append Logical scalar indicating whether \code{owners} and \code{uploaders} should be appended to the existing owners and uploaders, respectively, of the project.
+#' Ignored if \code{asset} is specified.
+#' @param append Logical scalar indicating whether \code{owners} and \code{uploaders} should be appended to the existing owners and uploaders, respectively, of the project/asset.
 #' If \code{FALSE}, the \code{owners} and \code{uploaders} are used to replace the existing values.
 #' @param registry String containing a path to the registry.
 #' @inheritParams createProject
@@ -49,10 +52,12 @@
 #' fetchPermissions("test", registry=info$registry)
 #'
 #' @export
-setPermissions <- function(project, registry, staging, url, owners=NULL, uploaders=NULL, globalWrite=NULL, append=TRUE) {
+setPermissions <- function(project, registry, staging, url, asset=NULL, owners=NULL, uploaders=NULL, globalWrite=NULL, append=TRUE) {
     perms <- list()
+    names(perms) <- character(0)
+
     if (append) {
-        old.perms <- fetchPermissions(project, registry=registry)
+        old.perms <- fetchPermissions(project, asset=asset, registry=registry, url=url)
         if (!is.null(owners)) {
             perms$owners <- as.list(union(unlist(old.perms$owners), owners))
         }
@@ -72,10 +77,14 @@ setPermissions <- function(project, registry, staging, url, owners=NULL, uploade
         perms$uploaders <- sanitize_uploaders(perms$uploaders)
     }
 
-    if (!is.null(globalWrite)) {
+    payload <- list(project=project)
+    if (!is.null(asset)) {
+        payload$asset <- asset
+    } else if (!is.null(globalWrite)) {
         perms$global_write <- globalWrite
     }
 
-    dump_request(staging, url, "set_permissions", list(project=project, permissions=perms))
+    payload$permissions <- perms
+    dump_request(staging, url, "set_permissions", payload)
     invisible(NULL)
 }

R/startGobbler.R

@@ -36,7 +36,7 @@
 #' 
 #' @export
 #' @importFrom utils download.file
-startGobbler <- function(staging=tempfile(), registry=tempfile(), port = NULL, wait = 1, version = "0.3.8", overwrite = FALSE) {
+startGobbler <- function(staging=tempfile(), registry=tempfile(), port = NULL, wait = 1, version = "0.3.9", overwrite = FALSE) {
     if (!is.null(running$active)) {
         return(list(new=FALSE, staging=running$staging, registry=running$registry, port=running$port, url=assemble_url(running$port)))
     }

tests/testthat/test-permissions.R

@@ -5,7 +5,7 @@ info <- startGobbler()
 removeProject("test-perms", staging=info$staging, url=info$url)
 createProject("test-perms", staging=info$staging, url=info$url, owners="LTLA")
 
-test_that("permission setting works as expected", {
+test_that("project-level permission setting works as expected", {
     until <- round(Sys.time() + 1000000)
     setPermissions("test-perms",
         owners="jkanche", 
@@ -59,3 +59,36 @@ test_that("permission setting works as expected", {
     perms <- fetchPermissions("test-perms", registry=info$registry)
     expect_false(perms$global_write)
 })
+
+test_that("asset-level permission setting works as expected", {
+    until <- round(Sys.time() + 1000000)
+    setPermissions("test-perms",
+        asset="foobar",
+        owners="jkanche", 
+        uploaders=list(
+           list(id="lawremi", until=until)
+        ),
+        staging=info$staging,
+        url=info$url,
+        registry=info$registry
+    )
+
+    perms <- fetchPermissions("test-perms", asset="foobar", registry=info$registry)
+    expect_identical(perms$owners, list("jkanche"))
+    expect_identical(length(perms$uploaders), 1L)
+    expect_identical(perms$uploaders[[1]]$id, "lawremi")
+    expect_equal(perms$uploaders[[1]]$until, until)
+    expect_null(perms$global_write)
+
+    # Works with remote.
+    rperms <- fetchPermissions("test-perms", asset="foobar", forceRemote=TRUE, registry=info$registry, url=info$url)
+    expect_identical(perms, rperms)
+
+    # Works correctly when there are no permissions.
+    perms <- fetchPermissions("test-perms", asset="stuff", registry=info$registry)
+    expect_identical(perms$owners, list())
+    expect_identical(perms$uploaders, list())
+
+    rperms <- fetchPermissions("test-perms", asset="stuff", forceRemote=TRUE, registry=info$registry, url=info$url)
+    expect_identical(perms, rperms)
+})