diff --git a/DESCRIPTION b/DESCRIPTION index 31a6be065..2adc75812 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,6 +24,7 @@ Imports: R6 (>= 2.0.0), stringi (>= 0.3.0), jsonlite (>= 0.9.16), + webutils (>= 1.1), httpuv (>= 1.5.0), crayon, promises (>= 1.1.0), @@ -64,6 +65,7 @@ Collate: 'paths.R' 'plumber-static.R' 'plumber-step.R' + 'post-parsers.R' 'response.R' 'serializer-content-type.R' 'serializer-html.R' diff --git a/NAMESPACE b/NAMESPACE index 8ceeaebe2..a0a2f99e8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ export(PlumberEndpoint) export(PlumberStatic) +export(addParser) export(addSerializer) export(do_configure_https) export(do_deploy_api) @@ -10,10 +11,17 @@ export(do_provision) export(do_remove_api) export(do_remove_forward) export(forward) +export(getCharacterSet) export(include_file) export(include_html) export(include_md) export(include_rmd) +export(parser_json) +export(parser_multi) +export(parser_octet) +export(parser_query) +export(parser_rds) +export(parser_text) export(plumb) export(plumber) export(randomCookieKey) @@ -32,5 +40,9 @@ importFrom(grDevices,dev.off) importFrom(grDevices,jpeg) importFrom(grDevices,png) importFrom(httpuv,runServer) +importFrom(jsonlite,fromJSON) +importFrom(jsonlite,toJSON) +importFrom(jsonlite,validate) importFrom(stats,runif) importFrom(stringi,stri_match_first_regex) +importFrom(webutils,parse_multipart) diff --git a/NEWS.md b/NEWS.md index 5966f024d..3c4bd927e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -33,6 +33,8 @@ plumber 0.5.0 ### New features +* Added Swagger support for array parameters using syntax `name:[type]` and new type `list` (synonym df, data.frame). (@meztez) + * Added support for promises in endpoints, filters, and hooks. ([#248](https://github.com/rstudio/plumber/pull/248)) * Added support to a router's run method to allow the `swagger` parameter to be a function that diff --git a/R/content-types.R b/R/content-types.R index a3730d0dc..bd2fdc28c 100644 --- a/R/content-types.R +++ b/R/content-types.R @@ -41,7 +41,8 @@ knownContentTypes <- list( docx='application/vnd.openxmlformats-officedocument.wordprocessingml.document', dotx='application/vnd.openxmlformats-officedocument.wordprocessingml.template', xlam='application/vnd.ms-excel.addin.macroEnabled.12', - xlsb='application/vnd.ms-excel.sheet.binary.macroEnabled.12') + xlsb='application/vnd.ms-excel.sheet.binary.macroEnabled.12', + rds='application/rds') getContentType <- function(ext, defaultType='application/octet-stream') { ct <- knownContentTypes[[tolower(ext)]] @@ -51,21 +52,12 @@ getContentType <- function(ext, defaultType='application/octet-stream') { return(ct) } -getCharacterSet <- function(contentType){ - default <- "UTF-8" - if (is.null(contentType)) { - return(default) - } - charsetStart <- attr( - gregexpr(".*charset=(.*)", contentType, perl = T)[[1]], - "capture.start" - ) - charsetStart <- as.integer(charsetStart) - as.character( - ifelse( - charsetStart > -1, - substr(contentType, charsetStart, nchar(contentType)), - default - ) - ) +#4x perf improvement when contentType is set +#' Request character set +#' @param contentType Request Content-Type header +#' @return Default to `UTF-8`. Otherwise return `charset` defined in request header. +#' @export +getCharacterSet <- function(contentType = NULL){ + if (is.null(contentType)) return("UTF-8") + stri_match_first_regex(paste(contentType,"; charset=UTF-8"), "charset=([^;\\s]*)")[,2] } diff --git a/R/globals.R b/R/globals.R index 63b6ba993..f33915762 100644 --- a/R/globals.R +++ b/R/globals.R @@ -1,3 +1,4 @@ .globals <- new.env() .globals$serializers <- list() .globals$processors <- new.env() +.globals$parsers <- list(func = list(), pattern = list()) diff --git a/R/json.R b/R/json.R index 96aa9427b..588ff9efe 100644 --- a/R/json.R +++ b/R/json.R @@ -1,7 +1,8 @@ -safeFromJSON <- function(txt, ...) { - if (!jsonlite::validate(txt)) { +#' @importFrom jsonlite validate fromJSON toJSON +#' @noRd +safeFromJSON <- function(txt) { + if (!validate(txt)) { stop("Argument 'txt' is not a valid JSON string.") } - - jsonlite::fromJSON(txt, ...) + fromJSON(txt) } diff --git a/R/parse-block.R b/R/parse-block.R index e75d6cba8..bc9b0cffb 100644 --- a/R/parse-block.R +++ b/R/parse-block.R @@ -28,7 +28,7 @@ parseBlock <- function(lineNum, file){ line <- file[lineNum] - epMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@(get|put|post|use|delete|head|options|patch)(\\s+(.*)$)?") + epMat <- stri_match(line, regex="^#['\\*]\\s*@(get|put|post|use|delete|head|options|patch)(\\s+(.*)$)?") if (!is.na(epMat[1,2])){ p <- stri_trim_both(epMat[1,4]) @@ -39,10 +39,11 @@ parseBlock <- function(lineNum, file){ if (is.null(paths)){ paths <- list() } + paths[[length(paths)+1]] <- list(verb = enumerateVerbs(epMat[1,2]), path = p) } - filterMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@filter(\\s+(.*)$)?") + filterMat <- stri_match(line, regex="^#['\\*]\\s*@filter(\\s+(.*)$)?") if (!is.na(filterMat[1,1])){ f <- stri_trim_both(filterMat[1,3]) @@ -58,7 +59,7 @@ parseBlock <- function(lineNum, file){ filter <- f } - preemptMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@preempt(\\s+(.*)\\s*$)?") + preemptMat <- stri_match(line, regex="^#['\\*]\\s*@preempt(\\s+(.*)\\s*$)?") if (!is.na(preemptMat[1,1])){ p <- stri_trim_both(preemptMat[1,3]) if (is.na(p) || p == ""){ @@ -71,7 +72,7 @@ parseBlock <- function(lineNum, file){ preempt <- p } - assetsMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@assets(\\s+(\\S*)(\\s+(\\S+))?\\s*)?$") + assetsMat <- stri_match(line, regex="^#['\\*]\\s*@assets(\\s+(\\S*)(\\s+(\\S+))?\\s*)?$") if (!is.na(assetsMat[1,1])){ dir <- stri_trim_both(assetsMat[1,3]) if (is.na(dir) || dir == ""){ @@ -88,7 +89,7 @@ parseBlock <- function(lineNum, file){ assets <- list(dir=dir, path=prefixPath) } - serMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@serializer(\\s+([^\\s]+)\\s*(.*)\\s*$)?") + serMat <- stri_match(line, regex="^#['\\*]\\s*@serializer(\\s+([^\\s]+)\\s*(.*)\\s*$)?") if (!is.na(serMat[1,1])){ s <- stri_trim_both(serMat[1,3]) if (is.na(s) || s == ""){ @@ -119,7 +120,7 @@ parseBlock <- function(lineNum, file){ } - shortSerMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@(json|html)(.*)$") + shortSerMat <- stri_match(line, regex="^#['\\*]\\s*@(json|html)(.*)$") if (!is.na(shortSerMat[1,2])) { s <- stri_trim_both(shortSerMat[1,2]) if (!is.null(serializer)){ @@ -149,7 +150,7 @@ parseBlock <- function(lineNum, file){ } - imageMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@(jpeg|png)([\\s\\(].*)?\\s*$") + imageMat <- stri_match(line, regex="^#['\\*]\\s*@(jpeg|png)([\\s\\(].*)?\\s*$") if (!is.na(imageMat[1,1])){ if (!is.null(image)){ # Must have already assigned. @@ -166,39 +167,30 @@ parseBlock <- function(lineNum, file){ } } - responseMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@response\\s+(\\w+)\\s+(\\S.+)\\s*$") + responseMat <- stri_match(line, regex="^#['\\*]\\s*@response\\s+(\\w+)\\s+(\\S.+)\\s*$") if (!is.na(responseMat[1,1])){ resp <- list() resp[[responseMat[1,2]]] <- list(description=responseMat[1,3]) responses <- c(responses, resp) } - paramMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@param(\\s+([^\\s]+)(\\s+(.*))?\\s*$)?") + paramMat <- stri_match(line, regex="^#['\\*]\\s*@param(\\s+([^\\s:]+):?([^\\s*]+)?(\\*)?(?:\\s+(.*))?\\s*$)?") if (!is.na(paramMat[1,2])){ - p <- stri_trim_both(paramMat[1,3]) - if (is.na(p) || p == ""){ - stopOnLine(lineNum, line, "No parameter specified.") - } - name <- paramMat[1,3] - type <- NA - - nameType <- stringi::stri_match(name, regex="^([^\\s]+):(\\w+)(\\*?)$") - if (!is.na(nameType[1,1])){ - name <- nameType[1,2] - type <- plumberToSwaggerType(nameType[1,3]) - #stopOnLine(lineNum, line, "No parameter type specified") - } - - - reqd <- FALSE - if (!is.na(nameType[1,4])){ - reqd <- nameType[1,4] == "*" + if (is.na(name)){ + stopOnLine(lineNum, line, "No parameter specified.") } - params[[name]] <- list(desc=paramMat[1,5], type=type, required=reqd) + type <- stri_replace_all(paramMat[1,4], "$1", regex = "^\\[([^\\]]*)\\]$") + type <- plumberToSwaggerType(type) + isArray <- stri_detect_regex(paramMat[1,4], "^\\[[^\\]]*\\]$") + isArray <- isArray && supportsArray(type) + isArray[is.na(isArray)] <- defaultSwaggerIsArray + required <- identical(paramMat[1,5], "*") + + params[[name]] <- list(desc=paramMat[1,6], type=type, required=required, isArray=isArray) } - tagMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@tag\\s+(\\S.+)\\s*") + tagMat <- stri_match(line, regex="^#['\\*]\\s*@tag\\s+(\\S.+)\\s*") if (!is.na(tagMat[1,1])){ t <- stri_trim_both(tagMat[1,2]) if (is.na(t) || t == ""){ @@ -210,7 +202,7 @@ parseBlock <- function(lineNum, file){ tags <- c(tags, t) } - commentMat <- stringi::stri_match(line, regex="^#['\\*]\\s*([^@\\s].*$)") + commentMat <- stri_match(line, regex="^#['\\*]\\s*([^@\\s].*$)") if (!is.na(commentMat[1,2])){ comments <- paste(comments, commentMat[1,2]) } @@ -226,7 +218,7 @@ parseBlock <- function(lineNum, file){ imageAttr = imageAttr, serializer = serializer, assets = assets, - params = params, + params = rev(params), comments = comments, responses = responses, tags = tags diff --git a/R/parse-globals.R b/R/parse-globals.R index cc8324766..0369cc3d2 100644 --- a/R/parse-globals.R +++ b/R/parse-globals.R @@ -56,7 +56,7 @@ parseOneGlobal <- function(fields, argument){ fields$produces <- strsplit(def, split="\\s+")[[1]] }, apiTag={ - tagMat <- stringi::stri_match(def, regex="^\\s*(\\w+)\\s+(\\S.+)\\s*$") + tagMat <- stri_match(def, regex="^\\s*(\\w+)\\s+(\\S.+)\\s*$") name <- tagMat[1,2] description <- tagMat[1,3] if(!is.null(fields$tags) && name %in% fields$tags$name) { diff --git a/R/plumber-step.R b/R/plumber-step.R index 2e2681708..e0e9929bb 100644 --- a/R/plumber-step.R +++ b/R/plumber-step.R @@ -150,7 +150,10 @@ PlumberEndpoint <- R6Class( responses = NA, #' @description retrieve endpoint typed parameters getTypedParams = function(){ - data.frame(name=private$regex$names, type=private$regex$types, stringsAsFactors = FALSE) + data.frame(name = private$regex$names, + type = private$regex$types, + isArray = private$regex$areArrays, + stringsAsFactors = FALSE) }, #' @field params endpoint parameters params = NA, @@ -180,8 +183,6 @@ PlumberEndpoint <- R6Class( self$verbs <- verbs self$path <- path - private$regex <- createPathRegex(path) - private$expr <- expr if (is.expression(expr)){ private$func <- eval(expr, envir) @@ -190,6 +191,8 @@ PlumberEndpoint <- R6Class( } private$envir <- envir + private$regex <- createPathRegex(path, self$getFuncParams()) + if (!missing(serializer) && !is.null(serializer)){ self$serializer <- serializer } @@ -216,6 +219,10 @@ PlumberEndpoint <- R6Class( #' @param path endpoint path getPathParams = function(path){ extractPathParams(private$regex, path) + }, + #' @description retrieve endpoint expression parameters + getFuncParams = function() { + getArgsMetadata(private$func) } ), private = list( diff --git a/R/plumber.R b/R/plumber.R index 440b3e973..d599eb2c7 100644 --- a/R/plumber.R +++ b/R/plumber.R @@ -215,6 +215,7 @@ plumber <- R6Class( private$serializer <- serializer_json() private$errorHandler <- defaultErrorHandler() private$notFoundHandler <- default404Handler + private$maxSize <- getOption('plumber.maxRequestSize', 0) #0 Unlimited # Add in the initial filters for (fn in names(filters)){ @@ -818,7 +819,24 @@ plumber <- R6Class( #' @param req request object #' @details required for httpuv interface onHeaders = function(req) { - NULL + maxSize <- private$maxSize + if (maxSize <= 0) + return(NULL) + + reqSize <- 0 + if (length(req$CONTENT_LENGTH) > 0) + reqSize <- as.numeric(req$CONTENT_LENGTH) + else if (length(req$HTTP_TRANSFER_ENCODING) > 0) + reqSize <- Inf + + if (reqSize > maxSize) { + return(list(status = 413L, + headers = list('Content-Type' = 'text/plain'), + body = 'Maximum upload size exceeded')) + } + else { + return(NULL) + } }, #' @description httpuv interface onWSOpen function #' @param ws WebSocket object @@ -1013,6 +1031,7 @@ plumber <- R6Class( errorHandler = NULL, notFoundHandler = NULL, + maxSize = NULL, # Max request size in bytes addFilterInternal = function(filter){ # Create a new filter and add it to the router diff --git a/R/post-body.R b/R/post-body.R index 29a3c24e2..9edea52b3 100644 --- a/R/post-body.R +++ b/R/post-body.R @@ -1,34 +1,53 @@ postBodyFilter <- function(req){ handled <- req$.internal$postBodyHandled - if (is.null(handled) || handled != TRUE){ - body <- paste0(req$rook.input$read_lines(), collapse = "\n") - charset <- getCharacterSet(req$HTTP_CONTENT_TYPE) - args <- parseBody(body, charset) - req$postBody <- body + if (is.null(handled) || handled != TRUE) { + # This will return raw bytes + body <- req$rook.input$read() + type <- req$HTTP_CONTENT_TYPE + args <- parseBody(body, type) req$args <- c(req$args, args) + req$postBodyRaw <- body + if (isTRUE(getOption("plumber.postBody", TRUE))) { + req$rook.input$rewind() + req$postBody <- paste0(req$rook.input$read_lines(), collapse = "\n") + } req$.internal$postBodyHandled <- TRUE } forward() } -#' @noRd -parseBody <- function(body, charset = "UTF-8"){ - # The body in a curl call can also include querystring formatted data - # Is there data in the request? - if (is.null(body) || length(body) == 0 || body == "") { - return(list()) - } +parseBody <- function(body, content_type = NULL) { + if (!is.raw(body)) {body <- charToRaw(body)} + toparse <- list(value = body, content_type = content_type) + parseRaw(toparse) +} - if (is.character(body)) { - Encoding(body) <- charset - } +parseRaw <- function(toparse) { + if (length(toparse$value) == 0L) return(list()) + parser <- parserPicker(toparse$content_type, toparse$value[1], toparse$filename) + do.call(parser(), toparse) +} - # Is it JSON data? - if (stri_startswith_fixed(body, "{")) { - ret <- safeFromJSON(body) +parserPicker <- function(content_type, first_byte, filename = NULL) { + #fast default to json when first byte is 7b (ascii {) + if (first_byte == as.raw(123L)) { + return(.globals$parsers$func[["json"]]) + } + if (is.null(content_type)) { + return(.globals$parsers$func[["query"]]) + } + # else try to find a match + patterns <- .globals$parsers$pattern + parser <- .globals$parsers$func[stri_startswith_fixed(content_type, patterns)] + # Should we warn when multiple parsers match? + # warning("Multiple body parsers matches for content-type : ", toparse$content_type, ". Parser ", names(parser)[1L], " used.") + if (length(parser) == 0L) { + if (is.null(filename)) { + return(.globals$parsers$func[["query"]]) + } else { + return(.globals$parsers$func[["octet"]]) + } } else { - # If not handle it as a query string - ret <- parseQS(body) + return(parser[[1L]]) } - ret } diff --git a/R/post-parsers.R b/R/post-parsers.R new file mode 100644 index 000000000..c97d103f6 --- /dev/null +++ b/R/post-parsers.R @@ -0,0 +1,179 @@ +#' Plumber Parsers +#' +#' Parsers are used in Plumber to transform the raw body content received +#' by a request to the API. +#' @name parsers +#' @rdname parsers +NULL + +#' Add a Parsers +#' +#' A parser is responsible for decoding the raw body content of a request into +#' a list of arguments that can be mapped to endpoint function arguments. +#' For instance, the \code{parser_json} parser content-type `application/json`. +#' The list of available parsers in plumber is global. +#' +#' @param name The name of the parser (character string) +#' @param parser The parser to be added. +#' @param pattern A pattern to match against the content-type of each part of +#' the request body. +#' +#' @details For instance, the \code{parser_json} pattern is `application/json`. +#' If `pattern` is not provided, will be set to `application/{name}`. +#' Detection is done assuming content-type starts with pattern and is +#' case sensitive. +#' +#' Parser function structure is something like below. Available parameters +#' to build parser are `value`, `content_type` and `filename` (only available +#' in `multipart-form` body). +#' ```r +#' parser <- function(...) { +#' function(value, content_type = "ct", filename, ...) { +#' # do something with raw value +#' } +#' } +#' ``` +#' +#' It should return a named list if you want values to map to +#' plumber endpoint function args. +#' +#' @examples +#' parser_json <- function(...) { +#' function(value, content_type = "application/json", ...) { +#' charset <- getCharacterSet(content_type) +#' value <- rawToChar(value) +#' Encoding(value) <- charset +#' safeFromJSON(value) +#' } +#' } +#' @md +#' @export +addParser <- function(name, parser, pattern = NULL) { + if (is.null(.globals$parsers)) { + .globals$parsers <- list() + } + if (!is.null(.globals$parsers$func[[name]])) { + stop("Already have a parser by the name of ", name) + } + if (is.null(pattern)) { + pattern <- paste0("application/", name) + } + .globals$parsers$func[[name]] <- parser + .globals$parsers$pattern[[name]] <- pattern +} + + + +#' JSON +#' @rdname parsers +#' @param ... Raw values and headers are passed there. +#' @export +parser_json <- function(...) { + function(value, content_type = NULL, ...) { + charset <- getCharacterSet(content_type) + value <- rawToChar(value) + Encoding(value) <- charset + safeFromJSON(value) + } +} + + + + +#' QUERY STRING +#' @rdname parsers +#' @export +parser_query <- function(...) { + function(value, content_type = NULL, ...) { + charset <- getCharacterSet(content_type) + value <- rawToChar(value) + Encoding(value) <- charset + parseQS(value) + } +} + + + + +#' TEXT +#' @rdname parsers +#' @export +parser_text <- function(...) { + function(value, content_type = NULL, ...) { + charset <- getCharacterSet(content_type) + value <- rawToChar(value) + Encoding(value) <- charset + value + } +} + + + + +#" RDS +#' @rdname parsers +#' @export +parser_rds <- function(...) { + function(value, filename, ...) { + tmp <- tempfile("plumb", fileext = paste0("_", basename(filename))) + on.exit(file.remove(tmp)) + writeBin(value, tmp) + readRDS(tmp) + } +} + + + + +#" MULTI +#' @rdname parsers +#' @export +#' @importFrom webutils parse_multipart +parser_multi <- function(...) { + function(value, content_type, ...) { + if (!stri_detect_fixed(content_type, "boundary=", case_insensitive = TRUE)) + stop("No boundary found in multipart content-type header: ", content_type) + 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) { + if (!is.null(x$filename)) { + x$content_type <- getContentType(tools::file_ext(x$filename)) + } + parseRaw(x) + }) + } +} + + + + +#' OCTET +#' @rdname parsers +#' @param ... Raw values and headers are passed there. +#' @export +parser_octet <- function(...) { + function(value, filename = NULL, ...) { + if (!is.null(filename) && isTRUE(getOption("plumber.saveFileToDisk", FALSE))) { + tmp <- tempfile("plumb", fileext = paste0("_", basename(filename))) + writeBin(value, tmp) + ret <- tmp + attr(ret, "filename") <- filename + return(ret) + } else { + attr(value, "filename") <- filename + return(value) + } + } +} + + + + +#' @include globals.R +addParser("json", parser_json, "application/json") +addParser("query", parser_query, "application/x-www-form-urlencoded") +addParser("text", parser_text, "text/") +addParser("rds", parser_rds, "application/rds") +addParser("multi", parser_multi, "multipart/form-data") +addParser("octet", parser_octet, "application/octet") diff --git a/R/query-string.R b/R/query-string.R index 0653f6226..aa2435bb2 100644 --- a/R/query-string.R +++ b/R/query-string.R @@ -1,6 +1,6 @@ queryStringFilter <- function(req){ handled <- req$.internal$queryStringHandled - if (is.null(handled) || handled != TRUE){ + if (is.null(handled) || handled != TRUE) { qs <- req$QUERY_STRING args <- parseQS(qs) req$args <- c(req$args, args) @@ -11,15 +11,18 @@ queryStringFilter <- function(req){ #' @noRd parseQS <- function(qs){ - if (is.null(qs) || length(qs) == 0 || qs == "") { + + if (is.null(qs) || length(qs) == 0L || qs == "") { return(list()) } - if (stri_startswith_fixed(qs, "?")) { - qs <- substr(qs, 2, nchar(qs)) - } - parts <- strsplit(qs, "&", fixed = TRUE)[[1]] - kv <- strsplit(parts, "=", fixed = TRUE) + qs <- stri_replace_first_regex(qs, "^[?]", "") + + args <- stri_split_fixed(qs, "&", omit_empty = TRUE)[[1L]] + kv <- lapply(args, function(x) { + # returns utf8 strings + httpuv::decodeURIComponent(stri_split_fixed(x, "=", omit_empty = TRUE)[[1]]) + }) kv <- kv[vapply(kv, length, numeric(1)) == 2] # Ignore incompletes if (length(kv) == 0) { @@ -27,92 +30,105 @@ parseQS <- function(qs){ return(list()) } - keys <- httpuv::decodeURIComponent(vapply(kv, "[[", character(1), 1)) # returns utf8 strings - if (any(Encoding(keys) != "unknown")) { + k <- vapply(kv, `[`, character(1), 1) + kenc <- unique(Encoding(k)) + if (any(kenc != "unknown")) { # https://github.com/rstudio/plumber/pull/314#discussion_r239992879 - non_ascii <- setdiff(unique(Encoding(keys)), "unknown") + non_ascii <- setdiff(kenc, "unknown") warning( "Query string parameter received in non-ASCII encoding. Received: ", paste0(non_ascii, collapse = ", ") ) } - vals <- vapply(kv, "[[", character(1), 2) - vals <- httpuv::decodeURIComponent(vals) # returns utf8 strings - - ret <- as.list(vals) - names(ret) <- keys - + v <- lapply(kv, `[`, 2) # If duplicates, combine - combine_elements <- function(name){ - unname(unlist(ret[names(ret)==name])) - } + unique_k <- unique(k) + v <- lapply(unique_k, function(x) do.call(c, v[k %in% x])) + names(v) <- unique_k - unique_names <- unique(names(ret)) - - ret <- lapply(unique_names, combine_elements) - names(ret) <- unique_names - - ret + return(v) } -createPathRegex <- function(pathDef){ +createPathRegex <- function(pathDef, funcParams = NULL){ # Create a regex from the defined path, substituting variables where appropriate - match <- stringi::stri_match_all( + match <- stri_match_all( pathDef, - # capture any plumber type () (typesToRegexps(type) will yell if it is unknown) + # capture any plumber type (). + # plumberToSwaggerType(types) will yell if it is unknown + # and can not be guessed from endpoint function args) # will be given the TYPE `defaultSwaggerType` - regex = "/<(\\.?[a-zA-Z][\\w_\\.]*)(:([^>]*))?>" + regex = "/<(\\.?[a-zA-Z][\\w_\\.]*)(?::([^>]*))?>" )[[1]] names <- match[,2] - types <- match[,4] - if (length(names) <= 1 && is.na(names)){ + # No path params + if (length(names) <= 1 && is.na(names)) { return( list( names = character(), types = NULL, regex = paste0("^", pathDef, "$"), - converters = NULL + converters = NULL, + areArrays = NULL ) ) } - if (length(types) > 0) { - types[is.na(types)] <- defaultSwaggerType + + plumberTypes <- stri_replace_all(match[,3], "$1", regex = "^\\[([^\\]]*)\\]$") + if (length(funcParams) > 0) { + # Override with detection of function args if type not found in map + idx <- !(plumberTypes %in% names(plumberToSwaggerTypeMap)) + plumberTypes[idx] <- sapply(funcParams, `[[`, "type")[names[idx]] + } + swaggerTypes <- plumberToSwaggerType(plumberTypes, inPath = TRUE) + + areArrays <- stri_detect_regex(match[,3], "^\\[[^\\]]*\\]$") + if (length(funcParams) > 0) { + # Override with detection of function args when false or na + idx <- (is.na(areArrays) | !areArrays) + areArrays[idx] <- sapply(funcParams, `[[`, "isArray")[names[idx]] } + areArrays <- areArrays & supportsArray(swaggerTypes) + areArrays[is.na(areArrays)] <- defaultSwaggerIsArray pathRegex <- pathDef - regexps <- typesToRegexps(types) + regexps <- typesToRegexps(swaggerTypes, areArrays) for (regex in regexps) { - pathRegex <- stringi::stri_replace_first_regex( + pathRegex <- stri_replace_first_regex( pathRegex, - pattern = "/(<\\.?[a-zA-Z][\\w_\\.:]*>)(/?)", - replacement = paste0("/(", regex, ")$2") + pattern = "/(?:<\\.?[a-zA-Z][\\w_\\.:\\[\\]]*>)(/?)", + replacement = paste0("/(", regex, ")$1") ) } list( names = names, - types = types, + types = swaggerTypes, regex = paste0("^", pathRegex, "$"), - converters = typeToConverters(types) + converters = typesToConverters(swaggerTypes, areArrays), + areArrays = areArrays ) } -typesToRegexps <- function(types) { +typesToRegexps <- function(swaggerTypes, areArrays = FALSE) { # return vector of regex strings - vapply( - swaggerTypeInfo[plumberToSwaggerType(types)], - `[[`, character(1), "regex" + mapply( + function(x, y) {x[[y]]}, + swaggerTypeInfo[swaggerTypes], + ifelse(areArrays, "regexArray", "regex"), + USE.NAMES = FALSE ) } -typeToConverters <- function(types) { +typesToConverters <- function(swaggerTypes, areArrays = FALSE) { # return list of functions - lapply( - swaggerTypeInfo[plumberToSwaggerType(types)], - `[[`, "converter" + mapply( + function(x, y) {x[[y]]}, + swaggerTypeInfo[swaggerTypes], + ifelse(areArrays, "converterArray", "converter"), + USE.NAMES = FALSE ) } @@ -120,7 +136,7 @@ typeToConverters <- function(types) { # Extract the params from a given path # @param def is the output from createPathRegex extractPathParams <- function(def, path){ - vals <- as.list(stringi::stri_match(path, regex = def$regex)[,-1]) + vals <- as.list(stri_match(path, regex = def$regex)[,-1]) names(vals) <- def$names if (!is.null(def$converters)){ diff --git a/R/serializer-json.R b/R/serializer-json.R index 0c3b64b5f..c38328d26 100644 --- a/R/serializer-json.R +++ b/R/serializer-json.R @@ -4,7 +4,7 @@ serializer_json <- function(...) { function(val, req, res, errorHandler) { tryCatch({ - json <- jsonlite::toJSON(val, ...) + json <- toJSON(val, ...) res$setHeader("Content-Type", "application/json") res$body <- json diff --git a/R/session-cookie.R b/R/session-cookie.R index c150334f0..dbe3ef3b0 100644 --- a/R/session-cookie.R +++ b/R/session-cookie.R @@ -212,7 +212,7 @@ encodeCookie <- function(x, key) { } xRaw <- x %>% - jsonlite::toJSON() %>% + toJSON() %>% charToRaw() if (is.null(key)) { diff --git a/R/swagger.R b/R/swagger.R index 4b24cbddc..7de285075 100644 --- a/R/swagger.R +++ b/R/swagger.R @@ -3,16 +3,41 @@ # calculate all swagger type information at once and use created information throughout package swaggerTypeInfo <- list() plumberToSwaggerTypeMap <- list() -defaultSwaggerType <- "string" +defaultSwaggerType <- structure("string", default = TRUE) +defaultSwaggerIsArray <- structure(FALSE, default = TRUE) local({ - addSwaggerInfo <- function(swaggerType, plumberTypes, regex, converter) { + addSwaggerInfo <- function(swaggerType, plumberTypes, + regex = NULL, converter = NULL, + format = NULL, + location = NULL, + realType = NULL, + arraySupport = FALSE) { swaggerTypeInfo[[swaggerType]] <<- list( regex = regex, - converter = converter + converter = converter, + format = format, + location = location, + arraySupport = arraySupport, + realType = realType ) + if (arraySupport == TRUE) { + swaggerTypeInfo[[swaggerType]] <<- modifyList( + swaggerTypeInfo[[swaggerType]], + 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) { plumberToSwaggerTypeMap[[plumberType]] <<- swaggerType @@ -27,34 +52,56 @@ local({ "boolean", c("bool", "boolean", "logical"), "[01tfTF]|true|false|TRUE|FALSE", - as.logical + as.logical, + location = c("query", "path"), + arraySupport = TRUE ) addSwaggerInfo( "number", c("dbl", "double", "float", "number", "numeric"), "-?\\\\d*\\\\.?\\\\d+", - as.numeric + as.numeric, + format = "double", + location = c("query", "path"), + arraySupport = TRUE ) addSwaggerInfo( "integer", c("int", "integer"), "-?\\\\d+", - as.integer + as.integer, + format = "int64", + location = c("query", "path"), + arraySupport = TRUE ) addSwaggerInfo( "string", c("chr", "str", "character", "string"), "[^/]+", - as.character + as.character, + location = c("query", "path"), + arraySupport = TRUE + ) + addSwaggerInfo( + "object", + c("list", "data.frame", "df"), + location = "requestBody" + ) + addSwaggerInfo( + "file", + c("file", "binary"), + location = "requestBody", + format = "binary", + realType = "string" ) }) #' Parse the given plumber type and return the typecast value #' @noRd -plumberToSwaggerType <- function(type) { +plumberToSwaggerType <- function(type, inPath = FALSE) { if (length(type) > 1) { - return(vapply(type, plumberToSwaggerType, character(1))) + return(vapply(type, plumberToSwaggerType, character(1), inPath, USE.NAMES = FALSE)) } # default type is "string" type if (is.na(type)) { @@ -69,10 +116,34 @@ plumberToSwaggerType <- function(type) { ) swaggerType <- defaultSwaggerType } + if (inPath && !"path" %in% swaggerTypeInfo[[swaggerType]]$location) { + warning( + "Unsupported path parameter type: ", type, ". Using type: ", defaultSwaggerType, + call. = FALSE + ) + swaggerType <- defaultSwaggerType + } return(swaggerType) } +#' Check if swagger type supports array +#' @noRd +supportsArray <- function(swaggerTypes) { + vapply( + swaggerTypeInfo[swaggerTypes], + `[[`, + logical(1), + "arraySupport", + USE.NAMES = FALSE) +} + +#' Filter swagger type +#' @noRd +filterSwaggerTypes <- function(matches, property) { + names(Filter(function(x) {any(matches %in% x[[property]])}, swaggerTypeInfo)) +} + #' Convert the endpoints as they exist on the router to a list which can #' be converted into a swagger definition for these endpoints #' @noRd @@ -86,8 +157,10 @@ prepareSwaggerEndpoint <- function(routerEndpointEntry, path = routerEndpointEnt # Get the params from the path pathParams <- routerEndpointEntry$getTypedParams() + # Get the params from endpoint func + funcParams <- routerEndpointEntry$getFuncParams() for (verb in routerEndpointEntry$verbs) { - params <- extractSwaggerParams(routerEndpointEntry$params, pathParams) + params <- extractSwaggerParams(routerEndpointEntry$params, pathParams, funcParams) # If we haven't already documented a path param, we should add it here. # FIXME: warning("Undocumented path parameters: ", paste0()) @@ -97,7 +170,8 @@ prepareSwaggerEndpoint <- function(routerEndpointEntry, path = routerEndpointEnt endptSwag <- list( summary = routerEndpointEntry$comments, responses = resps, - parameters = params, + parameters = params$parameters, + requestBody = params$requestBody, tags = routerEndpointEntry$tags ) @@ -124,54 +198,125 @@ extractResponses <- function(resps){ #' Extract the swagger-friendly parameter definitions from the endpoint #' paramters. #' @noRd -extractSwaggerParams <- function(endpointParams, pathParams){ +extractSwaggerParams <- function(endpointParams, pathParams, funcParams = NULL){ + + params <- list( + parameters = list(), + requestBody = list() + ) + inBody <- filterSwaggerTypes("requestBody", "location") + inRaw <- filterSwaggerTypes("binary", "format") + for (p in unique(c(names(endpointParams), pathParams$name, names(funcParams)))) { + + # Dealing with priorities endpointParams > pathParams > funcParams + # For each p, find out which source to trust for : + # `type`, `isArray`, `required` + # - `description` comes from endpointParams + # - `isArray` defines both `style` and `explode` + # - `default` and `example` comes from funcParams + # - `location` change to "path" when p is in pathParams and + # unused when `type` is "object" or "file" + # - When type is `object`, create a requestBody with content + # default to "application/json" + # - When type is `file`, change requestBody content to + # multipart/form-data - params <- list() - for (p in names(endpointParams)) { - location <- "query" if (p %in% pathParams$name) { location <- "path" + required <- TRUE + style <- "simple" + explode <- FALSE + type <- priorizeProperty(defaultSwaggerType, + pathParams[pathParams$name == p,]$type, + endpointParams[[p]]$type, + funcParams[[p]]$type) + type <- plumberToSwaggerType(type, inPath = TRUE) + isArray <- priorizeProperty(defaultSwaggerIsArray, + pathParams[pathParams$name == p,]$isArray, + endpointParams[[p]]$isArray, + funcParams[[p]]$isArray) + } else { + location <- "query" + style <- "form" + explode <- TRUE + type <- priorizeProperty(defaultSwaggerType, + endpointParams[[p]]$type, + funcParams[[p]]$type) + type <- plumberToSwaggerType(type) + isArray <- priorizeProperty(defaultSwaggerIsArray, + endpointParams[[p]]$isArray, + funcParams[[p]]$isArray) + required <- priorizeProperty(funcParams[[p]]$required, + endpointParams[[p]]$required) } - type <- endpointParams[[p]]$type - if (isNaOrNull(type)){ - if (location == "path") { - type <- plumberToSwaggerType(pathParams$type[pathParams$name == p]) - } else { - type <- defaultSwaggerType + # Building openapi definition + if (type %in% inBody) { + if (length(params$requestBody) == 0L) { + params$requestBody$content$`application/json`[["schema"]] <- + list(type = "object", properties = list()) } - } - - paramList <- list( - name = p, - description = endpointParams[[p]]$desc, - `in` = location, - required = endpointParams[[p]]$required, - schema = list( - type = type + property <- list( + type = type, + format = swaggerTypeInfo[[type]]$format, + example = funcParams[[p]]$example, + description = endpointParams[[p]]$desc ) - ) - - if (location == "path"){ - paramList$required <- TRUE + if (type %in% inRaw) { + names(params$requestBody$content) <- "multipart/form-data" + property$type <- swaggerTypeInfo[[type]]$realType + } + params$requestBody[[1]][[1]][[1]]$properties[[p]] <- property + if (required) { params$requestBody[[1]][[1]][[1]]$required <- + c(p, params$requestBody[[1]][[1]][[1]]$required)} + } else { + paramList <- list( + name = p, + description = endpointParams[[p]]$desc, + `in` = location, + required = required, + schema = list( + type = type, + format = swaggerTypeInfo[[type]]$format, + default = funcParams[[p]]$default + ) + ) + if (isArray) { + paramList$schema <- list( + type = "array", + items = list( + type = type, + format = swaggerTypeInfo[[type]]$format + ), + default = funcParams[[p]]$default + ) + paramList$style <- style + paramList$explode <- explode + } + params$parameters[[length(params$parameters) + 1]] <- paramList } - params[[length(params) + 1]] <- paramList - } params } - +#' Check na +#' @noRd isNa <- function(x) { if (is.list(x)) { return(FALSE) } is.na(x) } + +#' Check na or null +#' @noRd isNaOrNull <- function(x) { - isNa(x) || is.null(x) + any(isNa(x)) || is.null(x) } + +#' Remove na or null +#' @noRd removeNaOrNulls <- function(x) { # preemptively stop if (!is.list(x)) { @@ -180,6 +325,14 @@ removeNaOrNulls <- function(x) { if (length(x) == 0) { return(x) } + # Prevent example from being wiped out + if (!isNaOrNull(x$example)) { + saveExample <- TRUE + savedExample <- x$example + x$example <- NULL + } else { + saveExample <- FALSE + } # remove any `NA` or `NULL` elements toRemove <- vapply(x, isNaOrNull, logical(1)) @@ -191,5 +344,69 @@ removeNaOrNulls <- function(x) { ret <- lapply(x, removeNaOrNulls) class(ret) <- class(x) + # Put example back in + if (saveExample) { + ret$example <- savedExample + } + ret } + +#' For openapi definition +#' @noRd +priorizeProperty <- function(...) { + l <- list(...) + if (length(l) > 0L) { + isnullordefault <- vapply(l, function(x) {isNaOrNull(x) || isTRUE(attributes(x)$default)}, logical(1)) + # return the position of the first FALSE value or position 1 if all values are TRUE + return(l[[which.min(isnullordefault)]]) + } + return() +} + +#' Check if x is JSON serializable +#' @noRd +isJSONserializable <- function(x) { + testJSONserializable <- TRUE + tryCatch(toJSON(x), + error = function(cond) { + # Do we need to test for specific errors? + testJSONserializable <<- FALSE} + ) + testJSONserializable +} + +#' Extract metadata on args of plumberExpression +#' @noRd +getArgsMetadata <- function(plumberExpression){ + #return same format as getTypedParams or params? + if (!is.function(plumberExpression)) plumberExpression <- eval(plumberExpression) + args <- formals(plumberExpression) + lapply(args[!names(args) %in% c("...", "res", "req")], function(arg) { + required <- identical(arg, formals(function(x){})$x) + if (is.call(arg) || is.name(arg)) { + arg <- tryCatch( + eval(arg, envir = environment(plumberExpression)), + error = function(cond) {NA}) + } + # Check that it is possible to transform arg value into + # an example for the openAPI spec. Valid transform are + # either a logical, a numeric, a character or a list that + # is json serializable. Otherwise set to NA. Otherwise + # it + if (!is.logical(arg) && !is.numeric(arg) && !is.character(arg) + && !(is.list(arg) && isJSONserializable(arg))) { + message("Argument of class ", class(arg), " cannot be used to set default value in OpenAPI specifications.") + arg <- NA + } + type <- if (isNaOrNull(arg)) {NA} else {typeof(arg)} + type <- plumberToSwaggerType(type) + list( + default = arg, + example = arg, + required = required, + isArray = {if (length(arg) > 1L & supportsArray(type)) TRUE else defaultSwaggerIsArray}, + type = type + ) + }) +} diff --git a/man/PlumberEndpoint.Rd b/man/PlumberEndpoint.Rd index cb839e3e6..fd7d751fb 100644 --- a/man/PlumberEndpoint.Rd +++ b/man/PlumberEndpoint.Rd @@ -43,6 +43,7 @@ each separate verb/path into its own endpoint, so we just do that.} \item \href{#method-canServe}{\code{PlumberEndpoint$canServe()}} \item \href{#method-new}{\code{PlumberEndpoint$new()}} \item \href{#method-getPathParams}{\code{PlumberEndpoint$getPathParams()}} +\item \href{#method-getFuncParams}{\code{PlumberEndpoint$getFuncParams()}} \item \href{#method-clone}{\code{PlumberEndpoint$clone()}} } } @@ -150,6 +151,16 @@ retrieve endpoint path parameters } \if{html}{\out{}} } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-getFuncParams}{}}} +\subsection{Method \code{getFuncParams()}}{ +retrieve endpoint expression parameters +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{PlumberEndpoint$getFuncParams()}\if{html}{\out{
}} +} + } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/PlumberStatic.Rd b/man/PlumberStatic.Rd index 20556a4fe..def773153 100644 --- a/man/PlumberStatic.Rd +++ b/man/PlumberStatic.Rd @@ -74,7 +74,7 @@ A new \code{plumberstatic} router \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-print}{}}} \subsection{Method \code{print()}}{ -Print reprensation of plumberstatic router. +Print representation of \code{PlumberStatic()} router. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{PlumberStatic$print(prefix = "", topLevel = TRUE, ...)}\if{html}{\out{
}} } @@ -92,7 +92,7 @@ router, set to \code{TRUE}.} \if{html}{\out{}} } \subsection{Returns}{ -A terminal friendly represention of a plumberstatic router. +A terminal friendly represention of a \code{PlumberStatic()} router. } } \if{html}{\out{
}} diff --git a/man/PlumberStep.Rd b/man/PlumberStep.Rd index ea8a119b8..0e94aa6cd 100644 --- a/man/PlumberStep.Rd +++ b/man/PlumberStep.Rd @@ -39,7 +39,7 @@ of a request by a plumber router. \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-new}{}}} \subsection{Method \code{new()}}{ -Create a new \code{PlumberStep} object +Create a new \code{\link[=PlumberStep]{PlumberStep()}} object \subsection{Usage}{ \if{html}{\out{
}}\preformatted{PlumberStep$new(expr, envir, lines, serializer)}\if{html}{\out{
}} } diff --git a/man/addParser.Rd b/man/addParser.Rd new file mode 100644 index 000000000..64933b006 --- /dev/null +++ b/man/addParser.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/post-parsers.R +\name{addParser} +\alias{addParser} +\title{Add a Parsers} +\usage{ +addParser(name, parser, pattern = NULL) +} +\arguments{ +\item{name}{The name of the parser (character string)} + +\item{parser}{The parser to be added.} + +\item{pattern}{A pattern to match against the content-type of each part of +the request body.} +} +\description{ +A parser is responsible for decoding the raw body content of a request into +a list of arguments that can be mapped to endpoint function arguments. +For instance, the \code{parser_json} parser content-type \code{application/json}. +The list of available parsers in plumber is global. +} +\details{ +For instance, the \code{parser_json} pattern is \code{application/json}. +If \code{pattern} is not provided, will be set to \code{application/{name}}. +Detection is done assuming content-type starts with pattern and is +case sensitive. + +Parser function structure is something like below. Available parameters +to build parser are \code{value}, \code{content_type} and \code{filename} (only available +in \code{multipart-form} body).\if{html}{\out{
}}\preformatted{parser <- function(...) \{ + function(value, content_type = "ct", filename, ...) \{ + # do something with raw value + \} +\} +}\if{html}{\out{
}} + +It should return a named list if you want values to map to +plumber endpoint function args. +} +\examples{ +parser_json <- function(...) { + function(value, content_type = "application/json", ...) { + charset <- getCharacterSet(content_type) + value <- rawToChar(value) + Encoding(value) <- charset + safeFromJSON(value) + } +} +} diff --git a/man/do_provision.Rd b/man/do_provision.Rd index e005810f5..638bc3ae5 100644 --- a/man/do_provision.Rd +++ b/man/do_provision.Rd @@ -22,7 +22,7 @@ You may sign up for a Digital Ocean account \href{https://m.do.co/c/add0b50f54c4 This command is idempotent, so feel free to run it on a single server multiple times. } \details{ -Provisions a Ubuntu 16.04-x64 droplet with the following customizations: +Provisions a Ubuntu 20.04-x64 droplet with the following customizations: \itemize{ \item A recent version of R installed \item plumber installed globally in the system library diff --git a/man/getCharacterSet.Rd b/man/getCharacterSet.Rd new file mode 100644 index 000000000..3956288a0 --- /dev/null +++ b/man/getCharacterSet.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/content-types.R +\name{getCharacterSet} +\alias{getCharacterSet} +\title{Request character set} +\usage{ +getCharacterSet(contentType = NULL) +} +\arguments{ +\item{contentType}{Request Content-Type header} +} +\value{ +Default to \code{UTF-8}. Otherwise return \code{charset} defined in request header. +} +\description{ +Request character set +} diff --git a/man/include_file.Rd b/man/include_file.Rd index 23de3b5af..e01176260 100644 --- a/man/include_file.Rd +++ b/man/include_file.Rd @@ -21,7 +21,7 @@ include_rmd(file, res, format = NULL) \item{res}{The response object into which we'll write} \item{content_type}{If provided, the given value will be sent as the -\code{Content-type} header in the response.} +\code{Content-Type} header in the response.} \item{format}{Passed as the \code{output_format} to \code{rmarkdown::render}} } diff --git a/man/parsers.Rd b/man/parsers.Rd new file mode 100644 index 000000000..903b4e349 --- /dev/null +++ b/man/parsers.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/post-parsers.R +\name{parsers} +\alias{parsers} +\alias{parser_json} +\alias{parser_query} +\alias{parser_text} +\alias{parser_rds} +\alias{parser_multi} +\alias{parser_octet} +\title{Plumber Parsers} +\usage{ +parser_json(...) + +parser_query(...) + +parser_text(...) + +parser_rds(...) + +parser_multi(...) + +parser_octet(...) +} +\arguments{ +\item{...}{Raw values and headers are passed there.} +} +\description{ +Parsers are used in Plumber to transform the raw body content received +by a request to the API. +} diff --git a/man/plumber.Rd b/man/plumber.Rd index 3aaf3c39f..ded441ed1 100644 --- a/man/plumber.Rd +++ b/man/plumber.Rd @@ -29,8 +29,8 @@ details on the methods available on this object. It will be attributed automatically in the following priority order : option \code{plumber.port}, \code{port} value in global environment, a random port between 3000 and 10000 that is not blacklisted. When in unable to find -an available port, method will fail.\cr -\cr +an available port, method will fail. + \code{swagger} should be either a logial or set to a function . When \code{TRUE} or a function, multiple handles will be added to \code{plumber} object. OpenAPI json file will be served on paths \verb{/openapi.json} and \verb{/swagger.json}. Swagger UI @@ -38,8 +38,8 @@ will be served on paths \verb{/__swagger__/index.html} and \verb{/__swagger__/}. using a function, it will receive the plumber router as the first parameter and currrent swagger specifications as the second. This function should return a list containing swagger specifications. -See \url{https://swagger.io/docs/specification/}\cr -\cr +See \url{https://swagger.io/docs/specification/} + \code{swaggerCallback} When set, it will be called with a character string corresponding to the swagger UI url. It allows RStudio to open swagger UI when plumber router run method is executed using default \code{plumber.swagger.url} option. @@ -60,16 +60,16 @@ Plumber routers currently support four hooks: In all of the above you have access to a disposable environment in the \code{data} parameter that is created as a temporary data store for each request. Hooks can store temporary data in these hooks that can be reused by other hooks -processing this same request.\cr -\cr +processing this same request. + One feature when defining hooks in Plumber routers is the ability to modify the returned value. The convention for such hooks is: any function that accepts a parameter named \code{value} is expected to return the new value. This could be an unmodified version of the value that was passed in, or it could be a mutated value. But in either case, if your hook accepts a parameter named \code{value}, whatever your hook returns will be used as the new value -for the response.\cr -\cr +for the response. + You can add hooks using the \code{registerHook} method, or you can add multiple hooks at once using the \code{registerHooks} method which takes a name list in which the names are the names of the hooks, and the values are the diff --git a/man/randomCookieKey.Rd b/man/randomCookieKey.Rd index e7d4ff542..37670942a 100644 --- a/man/randomCookieKey.Rd +++ b/man/randomCookieKey.Rd @@ -10,7 +10,7 @@ randomCookieKey() A 64 digit hexadecimal string to be used as a key for cookie encryption. } \description{ -Uses a cryptographically secure pseudorandom number generator from \code{sodium::\link[sodium]{helpers}} to generate a 64 digit hexadecimal string. \href{https://github.com/jeroen/sodium}{'sodium'} wraps around \href{https://download.libsodium.org/doc/}{'libsodium'}. +Uses a cryptographically secure pseudorandom number generator from \code{\link[sodium:helpers]{sodium::helpers()}} to generate a 64 digit hexadecimal string. \href{https://github.com/jeroen/sodium}{'sodium'} wraps around \href{https://download.libsodium.org/doc/}{'libsodium'}. } \details{ Please see \code{\link{sessionCookie}} for more information on how to save the generated key. diff --git a/tests/testthat/files/.gitignore b/tests/testthat/files/.gitignore new file mode 100644 index 000000000..b49c113da --- /dev/null +++ b/tests/testthat/files/.gitignore @@ -0,0 +1 @@ +.httr-oauth diff --git a/tests/testthat/files/multipart-form.bin b/tests/testthat/files/multipart-form.bin new file mode 100644 index 000000000..f93676fd0 Binary files /dev/null and b/tests/testthat/files/multipart-form.bin differ diff --git a/tests/testthat/helper-mock-request.R b/tests/testthat/helper-mock-request.R index 8d41c28b4..5f87885e7 100644 --- a/tests/testthat/helper-mock-request.R +++ b/tests/testthat/helper-mock-request.R @@ -4,6 +4,8 @@ make_req <- function(verb, path, qs="", body=""){ req$REQUEST_METHOD <- toupper(verb) req$PATH_INFO <- path req$QUERY_STRING <- qs - req$rook.input <- list(read_lines = function(){ body }) + req$rook.input <- list(read_lines = function(){ body }, + read = function(){ charToRaw(body) }, + rewind = function(){ length(charToRaw(body)) }) req } diff --git a/tests/testthat/test-parse-block.R b/tests/testthat/test-parse-block.R index 38b781350..e31da3615 100644 --- a/tests/testthat/test-parse-block.R +++ b/tests/testthat/test-parse-block.R @@ -160,5 +160,4 @@ test_that("@html parameters produce an error", { expect_block_error("#' @html (key = \"val\")", "unused argument") }) - # TODO: more testing around filter, assets, endpoint, etc. diff --git a/tests/testthat/test-path-subst.R b/tests/testthat/test-path-subst.R index 26165ad40..08d7199f7 100644 --- a/tests/testthat/test-path-subst.R +++ b/tests/testthat/test-path-subst.R @@ -24,26 +24,58 @@ test_that("variables are typed", { expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "(-?\\d+)", "$")) + p <- createPathRegex("/car/") + expect_equal(p$names, "id") + expect_equal(p$regex, paste0("^/car/", "((?:(?:-?\\d+),?)+)", "$")) + p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "(-?\\d*\\.?\\d+)", "$")) + p <- createPathRegex("/car/") + expect_equal(p$names, "id") + expect_equal(p$regex, paste0("^/car/", "((?:(?:-?\\d*\\.?\\d+),?)+)", "$")) p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "(-?\\d*\\.?\\d+)", "$")) + p <- createPathRegex("/car/") + expect_equal(p$names, "id") + expect_equal(p$regex, paste0("^/car/", "((?:(?:-?\\d*\\.?\\d+),?)+)", "$")) p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "([01tfTF]|true|false|TRUE|FALSE)", "$")) + p <- createPathRegex("/car/") + expect_equal(p$names, "id") + expect_equal(p$regex, paste0("^/car/", "((?:(?:[01tfTF]|true|false|TRUE|FALSE),?)+)", "$")) p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "([01tfTF]|true|false|TRUE|FALSE)", "$")) + p <- createPathRegex("/car/") + expect_equal(p$names, "id") + expect_equal(p$regex, paste0("^/car/", "((?:(?:[01tfTF]|true|false|TRUE|FALSE),?)+)", "$")) + p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "([^/]+)", "$")) + p <- createPathRegex("/car/") + expect_equal(p$names, "id") + expect_equal(p$regex, paste0("^/car/", "((?:(?:[^/]+),?)+)", "$")) + expect_equal(p$areArrays, TRUE) + expect_equal(p$converters[[1]]("BOB,LUKE,GUY"), c("BOB", "LUKE", "GUY")) - + #Check that warnings happen on typo or unsupported type + expect_warning(createPathRegex("/car/"), + "Unrecognized type") + expect_warning(createPathRegex("/car/"), + "Unrecognized type") + expect_warning(createPathRegex("/car/"), + "Unrecognized type") + expect_warning(createPathRegex("/car/"), + "Unrecognized type") + expect_warning(createPathRegex("/car/"), + "Unrecognized type") }) @@ -78,3 +110,43 @@ test_that("integration of path parsing works", { list(error = "404 - Resource Not Found")) expect_equal(r$route(make_req("GET", "/car/sold/true"), PlumberResponse$new()), TRUE) }) + +test_that("multiple variations in path works nicely with function args detection", { + + # Check when detection is not provided + pathDef <- "/////////" + expect_warning(regex <- createPathRegex(pathDef), "Unrecognized type") + expect_equal(regex$types, c("string", "string", "integer", "string", "string", "string", "string", "string")) + expect_equal(regex$areArrays, c(FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE)) + + # Check when no args in endpoint function + dummy <- function() {} + funcParams <- getArgsMetadata(dummy) + expect_warning(regex <- createPathRegex(pathDef, funcParams), "Unrecognized type") + expect_equal(regex$types, c("string", "string", "integer", "string", "string", "string", "string", "string")) + expect_equal(regex$areArrays, c(FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE)) + + # Mix and match + dummy <- function(var0 = 420.69, + var1, + var2 = c(1L, 2L), + var3 = rnorm, + 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)) {} + funcParams <- getArgsMetadata(dummy) + regex <- suppressWarnings(createPathRegex(pathDef, funcParams)) + 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)) + + # Throw sand at it + pathDef <- "/<>/<:chr*>/<:chr>/" + regex <- suppressWarnings(createPathRegex(pathDef, funcParams)) + expect_equivalent(regex$types, "string") + expect_equal(regex$names, "henry") + # Since type IV is converted to string, areArrays can be TRUE + expect_equal(regex$areArrays, TRUE) + +}) diff --git a/tests/testthat/test-postbody.R b/tests/testthat/test-postbody.R index 62a4743db..cf6058a67 100644 --- a/tests/testthat/test-postbody.R +++ b/tests/testthat/test-postbody.R @@ -1,37 +1,66 @@ context("POST body") test_that("JSON is consumed on POST", { - expect_equal(parseBody('{"a":"1"}'), list(a = "1")) + expect_equal(parseBody('{"a":"1"}', content_type = NULL), list(a = "1")) }) test_that("Query strings on post are handled correctly", { expect_equivalent(parseBody("a="), list()) # It's technically a named list() - expect_equal(parseBody("a=1&b=&c&d=1"), list(a="1", d="1")) + expect_equal(parseBody("a=1&b=&c&d=1", content_type = NULL), list(a="1", d="1")) }) test_that("Able to handle UTF-8", { - expect_equal(parseBody('{"text":"élise"}', "UTF-8")$text, "élise") + expect_equal(parseBody('{"text":"élise"}', content_type = "application/json; charset=UTF-8")$text, "élise") }) -test_that("filter passes on charset", { - charset_passed <- "" +#charset moved to part parsing +test_that("filter passes on content-type", { + content_type_passed <- "" req <- list( .internal = list(postBodyHandled = FALSE), rook.input = list( - read_lines = function() { + read = function() { called <- TRUE - return("this is a body") - } + return(charToRaw("this is a body")) + }, + rewind = function() {}, + read_lines = function() {return("this is a body")} ), HTTP_CONTENT_TYPE = "text/html; charset=testset", args = c() ) with_mock( - parseBody = function(body, charset = "UTF-8") { - print(charset) + parseBody = function(body, content_type = "unknown") { + print(content_type) body }, - expect_output(postBodyFilter(req), "testset"), + expect_output(postBodyFilter(req), "text/html; charset=testset"), .env = "plumber" ) }) + +# parsers +test_that("Test text parser", { + expect_equal(parseBody("Ceci est un texte.", "text/html"), "Ceci est un texte.") +}) + +test_that("Test multipart parser", { + + bin_file <- test_path("files/multipart-form.bin") + body <- readBin(bin_file, what = "raw", n = file.info(bin_file)$size) + parsed_body <- parseBody(body, "multipart/form-data; boundary=----WebKitFormBoundaryMYdShB9nBc32BUhQ") + + 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(parsed_body[["json"]], list(a=2,b=4,c=list(w=3,t=5))) + + # Test save file option + opt_value = getOption("plumber.saveFileToDisk") + options(plumber.saveFileToDisk = TRUE) + parsed_body <- parseBody(body, "multipart/form-data; boundary=----WebKitFormBoundaryMYdShB9nBc32BUhQ") + expect_true(file.exists(parsed_body[["img1"]]) && file.exists(parsed_body[["img2"]])) + unlink(c(parsed_body[["img1"]], parsed_body[["img2"]])) + options(plumber.saveFileToDisk = opt_value) + +}) diff --git a/tests/testthat/test-sessions.R b/tests/testthat/test-sessions.R index 928d6da23..933f21d32 100644 --- a/tests/testthat/test-sessions.R +++ b/tests/testthat/test-sessions.R @@ -10,7 +10,9 @@ make_req_cookie <- function(verb, path, cookie) { req <- new.env() req$REQUEST_METHOD <- toupper(verb) req$PATH_INFO <- path - req$rook.input <- list(read_lines = function() { "" }) + req$rook.input <- list(read_lines = function() { "" }, + rewind = function() {}, + read = function() { charToRaw("") }) if (!missing(cookie)){ req$HTTP_COOKIE <- cookie } diff --git a/tests/testthat/test-swagger.R b/tests/testthat/test-swagger.R index 8648df211..9336708e3 100644 --- a/tests/testthat/test-swagger.R +++ b/tests/testthat/test-swagger.R @@ -11,8 +11,12 @@ test_that("plumberToSwaggerType works", { expect_equal(plumberToSwaggerType("character"), "string") + expect_equal(plumberToSwaggerType("df"), "object") + expect_equal(plumberToSwaggerType("list"), "object") + expect_equal(plumberToSwaggerType("data.frame"), "object") + expect_warning({ - expect_equal(plumberToSwaggerType("flargdarg"), "string") + expect_equal(plumberToSwaggerType("flargdarg"), defaultSwaggerType) }, "Unrecognized type:") }) @@ -39,12 +43,14 @@ test_that("params are parsed", { "#' @get /", "#' @param test Test docs", "#' @param required:character* Required param", - "#' @param another:int Another docs") + "#' @param another:int Another docs", + "#' @param multi:[int]* Required array param") b <- parseBlock(length(lines), lines) - expect_length(b$params, 3) - expect_equal(b$params$another, list(desc="Another docs", type="integer", required=FALSE)) - expect_equal(b$params$test, list(desc="Test docs", type=NA, required=FALSE)) - expect_equal(b$params$required, list(desc="Required param", type="string", required=TRUE)) + expect_length(b$params, 4) + expect_equal(b$params$another, list(desc="Another docs", type="integer", required=FALSE, isArray = FALSE)) + expect_equal(b$params$test, list(desc="Test docs", type=defaultSwaggerType, required=FALSE, isArray = FALSE)) + expect_equal(b$params$required, list(desc="Required param", type="string", required=TRUE, isArray = FALSE)) + expect_equal(b$params$multi, list(desc="Required array param", type="integer", required=TRUE, isArray = TRUE)) b <- parseBlock(1, "") expect_null(b$params) @@ -134,49 +140,111 @@ test_that("extractResponses works", { test_that("extractSwaggerParams works", { ep <- list(id=list(desc="Description", type="integer", required=FALSE), id2=list(desc="Description2", required=FALSE), # No redundant type specification - make=list(desc="Make description", type="string", required=FALSE)) - pp <- data.frame(name=c("id", "id2"), type=c("int", "int")) + make=list(desc="Make description", type="string", required=FALSE), + prices=list(desc="Historic sell prices", type="numeric", required = FALSE, isArray = TRUE), + claims=list(desc="Insurance claims", type="object", required = FALSE)) + pp <- data.frame(name=c("id", "id2", "owners"), type=c("int", "int", "chr"), isArray = c(FALSE, FALSE, TRUE), stringsAsFactors = FALSE) params <- extractSwaggerParams(ep, pp) - expect_equal(params[[1]], + expect_equal(params$parameters[[1]], list(name="id", description="Description", `in`="path", required=TRUE, # Made required b/c path arg schema = list( - type="integer"))) - expect_equal(params[[2]], + type="integer", + format="int64", + default=NULL))) + expect_equal(params$parameters[[2]], list(name="id2", description="Description2", `in`="path", required=TRUE, # Made required b/c path arg schema = list( - type="integer"))) - expect_equal(params[[3]], + type="integer", + format="int64", + default=NULL))) + expect_equal(params$parameters[[3]], list(name="make", description="Make description", `in`="query", required=FALSE, schema = list( - type="string"))) + type="string", + format=NULL, + default=NULL))) + expect_equal(params$parameters[[4]], + list(name="prices", + description="Historic sell prices", + `in`="query", + required=FALSE, + schema = list( + type="array", + items= list( + type="number", + format="double"), + default = NULL), + style="form", + explode=TRUE)) + expect_equal(params$parameters[[5]], + list(name="owners", + description=NULL, + `in`="path", + required=TRUE, + schema = list( + type="array", + items= list( + type="string", + format=NULL), + default = NULL), + style="simple", + explode=FALSE)) + expect_equal(params$requestBody, + list(content = list( + `application/json` = list( + schema = list( + type = "object", + properties = list( + claims = list( + type = "object", + format = NULL, + example = NULL, + description = "Insurance claims"))))))) # If id were not a path param it should not be promoted to required params <- extractSwaggerParams(ep, NULL) - idParam <- params[[which(vapply(params, `[[`, character(1), "name") == "id")]] + idParam <- params$parameters[[which(vapply(params$parameters, `[[`, character(1), "name") == "id")]] expect_equal(idParam$required, FALSE) expect_equal(idParam$schema$type, "integer") - for (param in params) { - expect_equal(length(param), 5) + for (param in params$parameters) { + if (param$schema$type != "array") { + expect_equal(length(param), 5) + } else { + expect_equal(length(param), 7) + } } + # Check if we can pass a single path parameter without a @param line match + params <- extractSwaggerParams(NULL, pp[3,]) + expect_equal(params$parameters[[1]], + list(name="owners", + description=NULL, + `in`="path", + required=TRUE, + schema = list( + type="array", + items= list( + type="string", + format=NULL), + default=NULL), + style="simple", + explode=FALSE)) + params <- extractSwaggerParams(NULL, NULL) - expect_equal(length(params), 0) + expect_equal(sum(sapply(params, length)), 0) }) - - - test_that("api kitchen sink", { skip_on_cran() @@ -254,3 +322,41 @@ test_that("api kitchen sink", { }) + +test_that("multiple variations in function extract correct metadata", { + dummy <- function(var0 = 420.69, + var1, + var2 = c(1L, 2L), + var3 = rnorm, + var4 = NULL, + var5 = FALSE, + var6 = list(name = c("luke", "bob"), lastname = c("skywalker", "ross")), + var7 = .GlobalEnv, + var8 = list(a = 2, b = mean, c = .GlobalEnv)) {} + funcParams <- getArgsMetadata(dummy) + expect_identical(sapply(funcParams, `[[`, "required"), + c(var0 = FALSE, var1 = TRUE, var2 = FALSE, var3 = FALSE, var4 = FALSE, + var5 = FALSE, var6 = FALSE, var7 = FALSE, var8 = FALSE)) + expect_identical(lapply(funcParams, `[[`, "default"), + list(var0 = 420.69, var1 = NA, var2 = 1L:2L, var3 = NA, var4 = NA, var5 = FALSE, + var6 = list(name = c("luke", "bob"), lastname = c("skywalker", "ross")), var7 = NA, var8 = NA)) + expect_identical(lapply(funcParams, `[[`, "example"), + list(var0 = 420.69, var1 = NA, var2 = 1L:2L, var3 = NA, var4 = NA, var5 = FALSE, + var6 = list(name = c("luke", "bob"), lastname = c("skywalker", "ross")), var7 = NA, var8 = NA)) + expect_identical(lapply(funcParams, `[[`, "isArray"), + list(var0 = defaultSwaggerIsArray, var1 = defaultSwaggerIsArray, var2 = TRUE, + var3 = defaultSwaggerIsArray, var4 = defaultSwaggerIsArray, + var5 = defaultSwaggerIsArray, var6 = defaultSwaggerIsArray, + var7 = defaultSwaggerIsArray, var8 = defaultSwaggerIsArray)) + expect_identical(lapply(funcParams, `[[`, "type"), + list(var0 = "number", var1 = defaultSwaggerType, var2 = "integer", var3 = defaultSwaggerType, var4 = defaultSwaggerType, + var5 = "boolean", var6 = "object", var7 = defaultSwaggerType, var8 = defaultSwaggerType)) + +}) + +test_that("priorize works as expected", { + expect_identical("abc", priorizeProperty(structure("zzz", default = TRUE), NULL, "abc")) + expect_identical(NULL, priorizeProperty(NULL, NULL, NULL)) + expect_identical(structure("zzz", default = TRUE), priorizeProperty(structure("zzz", default = TRUE), NULL, NA)) + expect_identical(NULL, priorizeProperty()) +})