Upload an arbitrary number of files

R/openapi-spec.R

@@ -123,6 +123,16 @@ parametersSpecification <- function(endpointParams, pathParams, funcParams = NUL
       if (type %in% inRaw) {
         names(params$requestBody$content) <- "multipart/form-data"
         property$type <- apiTypesInfo[[type]]$realType
+        property$example <- NULL
+      }
+      if (isArray) {
+        property$items <- list(
+          type = property$type,
+          format = property$format,
+          example = property$example)
+        property$type <- "array"
+        property$format <- NULL
+        property$example <- NULL
       }
       params$requestBody[[1]][[1]][[1]]$properties[[p]] <- property
       if (required) { params$requestBody[[1]][[1]][[1]]$required <-
@@ -262,7 +272,7 @@ getArgsMetadata <- function(plumberExpression){
     }
     type <- if (isNaOrNull(arg)) {NA} else {typeof(arg)}
     type <- plumberToApiType(type)
-    isArray <- {if (length(arg) > 1L && type %in% filterApiTypes(TRUE, "arraySupport")) TRUE else defaultIsArray}
+    isArray <- if (isTRUE(length(arg) > 1L)) {TRUE} else {defaultIsArray}
     list(
       default = arg,
       example = arg,

R/openapi-types.R

@@ -11,34 +11,26 @@ add_api_info_onLoad <- function() {
                          regex = NULL, converter = NULL,
                          format = NULL,
                          location = NULL,
-                         realType = NULL,
-                         arraySupport = FALSE) {
+                         realType = NULL) {
     apiTypesInfo[[apiType]] <<-
       list(
         regex = regex,
         converter = converter,
         format = format,
         location = location,
-        arraySupport = arraySupport,
-        realType = realType
+        realType = realType,
+        # Q: Do we need to safe guard against special characters, such as `,`?
+        # https://github.com/rstudio/plumber/pull/532#discussion_r439584727
+        # A: https://swagger.io/docs/specification/serialization/
+        # > Additionally, the allowReserved keyword specifies whether the reserved
+        # > characters :/?#[]@!$&'()*+,;= in parameter values are allowed to be sent as they are,
+        # > or should be percent-encoded. By default, allowReserved is false, and reserved characters
+        # > are percent-encoded. For example, / is encoded as %2F (or %2f), so that the parameter
+        # > value quotes/h2g2.txt will be sent as quotes%2Fh2g2.txt
+        regexArray = paste0("(?:(?:", regex, "),?)+"),
+        converterArray = function(x) {converter(stri_split_fixed(x, ",")[[1]])}
       )
 
-    if (arraySupport == TRUE) {
-      apiTypesInfo[[apiType]] <<- utils::modifyList(
-        apiTypesInfo[[apiType]],
-        list(regexArray = paste0("(?:(?:", regex, "),?)+"),
-             # Q: Do we need to safe guard against special characters, such as `,`?
-             # https://github.com/rstudio/plumber/pull/532#discussion_r439584727
-             # A: https://swagger.io/docs/specification/serialization/
-             # > Additionally, the allowReserved keyword specifies whether the reserved
-             # > characters :/?#[]@!$&'()*+,;= in parameter values are allowed to be sent as they are,
-             # > or should be percent-encoded. By default, allowReserved is false, and reserved characters
-             # > are percent-encoded. For example, / is encoded as %2F (or %2f), so that the parameter
-             # > value quotes/h2g2.txt will be sent as quotes%2Fh2g2.txt
-             converterArray = function(x) {converter(stri_split_fixed(x, ",")[[1]])})
-      )
-    }
-
     for (plumberType in plumberTypes) {
       plumberToApiTypeMap[[plumberType]] <<- apiType
     }
@@ -53,34 +45,30 @@ add_api_info_onLoad <- function() {
     c("bool", "boolean", "logical"),
     "[01tfTF]|true|false|TRUE|FALSE",
     as.logical,
-    location = c("query", "path"),
-    arraySupport = TRUE
+    location = c("query", "path")
   )
   addApiInfo(
     "number",
     c("dbl", "double", "float", "number", "numeric"),
     "-?\\\\d*\\\\.?\\\\d+",
     as.numeric,
     format = "double",
-    location = c("query", "path"),
-    arraySupport = TRUE
+    location = c("query", "path")
   )
   addApiInfo(
     "integer",
     c("int", "integer"),
     "-?\\\\d+",
     as.integer,
     format = "int64",
-    location = c("query", "path"),
-    arraySupport = TRUE
+    location = c("query", "path")
   )
   addApiInfo(
     "string",
     c("chr", "str", "character", "string"),
     "[^/]+",
     as.character,
-    location = c("query", "path"),
-    arraySupport = TRUE
+    location = c("query", "path")
   )
   addApiInfo(
     "object",

R/parse-body.R

@@ -46,8 +46,8 @@ parser_picker <- function(content_type, first_byte, filename = NULL, parsers = N
 
   # parse as a query string
   if (length(content_type) == 0) {
-    # fast default to json when first byte is 7b (ascii {)
-    if (first_byte == as.raw(123L)) {
+    #fast default to json when first byte is 7b or 5b (ascii { or [)
+    if (first_byte %in% as.raw(c(91L, 123L))) {
       return(parsers$alias$json)
     }
 
@@ -433,8 +433,9 @@ parser_rds <- function(...) {
 #' @export
 parser_octet <- function() {
   function(value, filename = NULL, ...) {
-    attr(value, "filename") <- filename
-    value
+    arg <- list(value)
+    names(arg) <- filename
+    return(arg)
   }
 }
 
@@ -449,7 +450,7 @@ parser_multi <- function() {
     boundary <- stri_match_first_regex(content_type, "boundary=([^; ]{2,})", case_insensitive = TRUE)[,2]
     toparse <- parse_multipart(value, boundary)
     # content-type detection
-    lapply(toparse, function(x) {
+    args <- lapply(toparse, function(x) {
       if (
         is.null(x$content_type) ||
         # allows for files to be shipped as octect, but parsed using the matching value in `knownContentTypes`
@@ -464,6 +465,9 @@ parser_multi <- function() {
       x$parsers <- parsers
       parse_raw(x)
     })
+    # combine together args that share the same name for
+    # multifiles support so they get properly matched by do.call
+    combine_keys(args, FALSE)
   }
 }
 

R/parse-query.R

@@ -47,37 +47,10 @@ parseQS <- function(qs){
   }
 
   vals <- lapply(kv, `[`, 2)
+  names(vals) <- keys
 
   # If duplicates, combine
-  unique_keys <- unique(keys)
-
-  # equivalent code output, `split` is much faster with larger objects
-  # Testing on personal machine had a breakpoint around 150 letters as query parameters
-  ## n <- 150
-  ## k <- sample(letters, n, replace = TRUE)
-  ## v <- as.list(sample(1L, n, replace = TRUE))
-  ## microbenchmark::microbenchmark(
-  ##   split = {
-  ##     lapply(split(v, k), function(x) unname(unlist(x)))
-  ##   },
-  ##   not_split = {
-  ##     lapply(unique(k), function(x) {
-  ##       unname(unlist(v[k == x]))
-  ##     })
-  ##   }
-  ## )
-  vals <-
-    if (length(unique_keys) > 150) {
-      lapply(split(vals, keys), function(items) unname(unlist(items)))
-    } else {
-      # n < 150
-      lapply(unique_keys, function(key) {
-        unname(unlist(vals[keys == key]))
-      })
-    }
-  names(vals) <- unique_keys
-
-  return(vals)
+  combine_keys(vals)
 }
 
 createPathRegex <- function(pathDef, funcParams = NULL){
@@ -118,7 +91,6 @@ createPathRegex <- function(pathDef, funcParams = NULL){
     idx <- (is.na(areArrays) | !areArrays)
     areArrays[idx] <- sapply(funcParams, `[[`, "isArray")[names[idx]]
   }
-  areArrays <- areArrays & apiTypes %in% filterApiTypes(TRUE, "arraySupport")
   areArrays[is.na(areArrays)] <- defaultIsArray
 
   pathRegex <- pathDef
@@ -178,3 +150,61 @@ extractPathParams <- function(def, path){
 
   vals
 }
+
+#' combine args that share the same name
+#' @noRd
+combine_keys <- function(obj, call_unlist = TRUE) {
+
+  keys <- names(obj)
+  unique_keys <- unique(keys)
+
+  if (length(unique_keys) == length(keys)) {
+    return(obj)
+  }
+
+  vals <- unname(obj)
+
+  cleanup_item <-
+    if (isTRUE(call_unlist)) {
+      function(x) {
+        unname(unlist(x))
+      }
+    } else {
+      function(x) {
+        if (length(x) == 1) {
+          x[[1]]
+        } else {
+          do.call(c, x)
+        }
+      }
+    }
+
+  # equivalent code output, `split` is much faster with larger objects
+  # Testing on personal machine had a breakpoint around 150 letters as query parameters
+  ## n <- 150
+  ## k <- sample(letters, n, replace = TRUE)
+  ## v <- as.list(sample(1L, n, replace = TRUE))
+  ## microbenchmark::microbenchmark(
+  ##   split = {
+  ##     lapply(split(v, k), function(x) unname(unlist(x)))
+  ##   },
+  ##   not_split = {
+  ##     lapply(unique(k), function(x) {
+  ##       unname(unlist(v[k == x]))
+  ##     })
+  ##   }
+  ## )
+  vals <-
+    if (length(unique_keys) > 150) {
+      lapply(split(vals, keys), function(items) {
+        cleanup_item(items)
+      })
+    } else {
+      # n < 150
+      lapply(unique_keys, function(key) {
+        cleanup_item(vals[keys == key])
+      })
+    }
+  names(vals) <- unique_keys
+  vals
+}

R/plumb-block.R

@@ -231,7 +231,6 @@ plumbBlock <- function(lineNum, file, envir = parent.frame()){
       plumberType <- stri_replace_all(paramMat[1,4], "$1", regex = "^\\[([^\\]]*)\\]$")
       apiType <- plumberToApiType(plumberType)
       isArray <- stri_detect_regex(paramMat[1,4], "^\\[[^\\]]*\\]$")
-      isArray <- isArray && apiType %in% filterApiTypes(TRUE, "arraySupport")
       isArray[is.na(isArray)] <- defaultIsArray
       required <- identical(paramMat[1,5], "*")
 

tests/testthat/test-openapi.R

@@ -331,8 +331,8 @@ test_that("multiple variations in function extract correct metadata", {
                     var4 = NULL,
                     var5 = FALSE,
                     var6 = list(name = c("luke", "bob"), lastname = c("skywalker", "ross")),
-                    var7 = .GlobalEnv,
-                    var8 = list(a = 2, b = mean, c = .GlobalEnv)) {}
+                    var7 = new.env(parent = .GlobalEnv),
+                    var8 = list(a = 2, b = mean, c = new.env(parent = .GlobalEnv))) {}
   funcParams <- getArgsMetadata(dummy)
   expect_identical(sapply(funcParams, `[[`, "required"),
                    c(var0 = FALSE, var1 = TRUE, var2 = FALSE, var3 = FALSE, var4 = FALSE,
@@ -346,7 +346,7 @@ test_that("multiple variations in function extract correct metadata", {
   expect_identical(lapply(funcParams, `[[`, "isArray"),
                    list(var0 = defaultIsArray, var1 = defaultIsArray, var2 = TRUE,
                         var3 = defaultIsArray, var4 = defaultIsArray,
-                        var5 = defaultIsArray, var6 = defaultIsArray,
+                        var5 = defaultIsArray, var6 = TRUE,
                         var7 = defaultIsArray, var8 = defaultIsArray))
   expect_identical(lapply(funcParams, `[[`, "type"),
                    list(var0 = "number", var1 = defaultApiType, var2 = "integer", var3 = defaultApiType, var4 = defaultApiType,

tests/testthat/test-parse-body.R

@@ -95,7 +95,7 @@ test_that("Test multipart parser", {
 
   expect_equal(names(parsed_body), c("json", "img1", "img2", "rds"))
   expect_equal(parsed_body[["rds"]], women)
-  expect_equal(attr(parsed_body[["img1"]], "filename"), "avatar2-small.png")
+  expect_equal(names(parsed_body[["img1"]]), "avatar2-small.png")
   expect_equal(parsed_body[["json"]], list(a=2,b=4,c=list(w=3,t=5)))
 })
 
@@ -108,3 +108,22 @@ test_that("Test multipart respect content-type", {
                             make_parser(c("multi", "tsv")))
   expect_s3_class(parsed_body$sample_name, "data.frame")
 })
+
+test_that("Test an array of files upload", {
+  bin_file <- test_path("files/multipart-files-array.bin")
+  body <- readBin(bin_file, what = "raw", n = file.info(bin_file)$size)
+  parsed_body <- parse_body(body,
+                            "multipart/form-data; boundary=---------------------------286326291134907228894146459692",
+                            make_parser("all"))
+  expect_equal(names(parsed_body), c("files", "dt"))
+  expect_length(parsed_body[["files"]], 4)
+  expect_equal(names(parsed_body[["files"]])[2], "text1.bin")
+  expect_equal(rawToChar(parsed_body[["files"]][[2]]), "a")
+})
+
+test_that("Key val combiner does not alter structure of results", {
+  sample1 <- list(a = women, b = 1:4, c = mtcars)
+  sample2 <- list(a = women, b = 1:4, a = mtcars, c=mtcars)
+  expect_equal(combine_keys(sample1, FALSE), sample1)
+  expect_equal(combine_keys(sample2, FALSE), list(a = c(women, mtcars), b = 1:4, c=mtcars))
+})

tests/testthat/test-parser.R

@@ -67,7 +67,7 @@ test_that("parsers work", {
     })
   expect_equal(names(parsed_body), c("json", "img1", "img2", "rds"))
   expect_equal(parsed_body[["rds"]], women)
-  expect_equal(attr(parsed_body[["img1"]], "filename"), "avatar2-small.png")
+  expect_equal(names(parsed_body[["img1"]]), "avatar2-small.png")
   expect_equal(parsed_body[["json"]], list(a=2,b=4,c=list(w=3,t=5)))
 
 

tests/testthat/test-path-subst.R

@@ -136,12 +136,12 @@ test_that("multiple variations in path works nicely with function args detection
                     var4 = NULL,
                     var5 = c(TRUE, FALSE),
                     var6 = list(name = c("luke", "bob"), lastname = c("skywalker", "ross")),
-                    var7 = .GlobalEnv,
-                    var8 = list(a = 2, b = mean, c = .GlobalEnv)) {}
+                    var7 = new.env(parent = .GlobalEnv),
+                    var8 = list(a = 2, b = mean, c = new.env(parent = .GlobalEnv))) {}
   funcParams <- getArgsMetadata(dummy)
   expect_warning(regex <- createPathRegex(pathDef, funcParams), "Unsupported path parameter type")
   expect_equal(regex$types, c("string", "string", "integer", "string", "string", "boolean", "string", "string"))
-  expect_equal(regex$areArrays, c(FALSE, FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, TRUE))
+  expect_equal(regex$areArrays, c(FALSE, FALSE, TRUE, FALSE, FALSE, TRUE, TRUE, TRUE))
 
   # Throw sand at it
   pathDef <- "/<>/<:chr*>/<:chr>/<henry:[IV]>"