documenting parsers and serializers and provide a user facing getter for each

Author: thomasp85

NAMESPACE

@@ -63,8 +63,31 @@ export(api_session_cookie)
 export(api_statics)
 export(api_trace)
 export(api_trace_header)
+export(format_cat)
+export(format_csv)
+export(format_feather)
+export(format_format)
+export(format_geojson)
+export(format_htmlwidget)
+export(format_parquet)
+export(format_print)
+export(format_rds)
+export(format_tsv)
+export(format_unboxed)
+export(format_yaml)
+export(get_parsers)
+export(get_serializers)
 export(is_plumber_api)
+export(parse_csv)
+export(parse_feather)
+export(parse_geojson)
+export(parse_octet)
+export(parse_parquet)
 export(parse_plumber_file)
+export(parse_rds)
+export(parse_text)
+export(parse_tsv)
+export(parse_yaml)
 export(register_parser)
 export(register_serializer)
 import(rlang)

R/api_handlers.R

@@ -192,10 +192,12 @@ handle_constructor <- function(method, header = FALSE) {
 #' path
 #' @param serializers A named list of serializers that can be used to format the
 #' response before sending it back to the client. Which one is selected is based
-#' on the request `Accept` header
+#' on the request `Accept` header. See [get_serializers()] for a helper to
+#' construct this
 #' @param parsers A named list of parsers that can be used to parse the
 #' request body before passing it in as the `body` argument. Which one is
-#' selected is based on the request `Content-Type` header
+#' selected is based on the request `Content-Type` header. See [get_parsers()]
+#' for a helper to construct this
 #' @param use_strict_serializer By default, if a serializer that respects the
 #' requests `Accept` header cannot be found, then the first of the provided ones
 #' are used. Setting this to `TRUE` will instead send back a

R/parse_plumber_file.R

@@ -171,15 +171,15 @@ parse_handler_block <- function(
   } else {
     serializers <- NULL
   }
-  serializers <- get_serializers(serializers, env)
+  serializers <- get_serializers_internal(serializers, env)
 
   parsers <- which(tags == "parser")
   if (length(parsers) != 0) {
     parsers <- trimws(values[parsers])
   } else {
     parsers <- NULL
   }
-  parsers <- get_parsers(parsers, env)
+  parsers <- get_parsers_internal(parsers, env)
 
   download <- which(tags == "download")
   if (length(download) != 0) {

R/parsers.R

@@ -1,11 +1,18 @@
 registry$parsers <- list()
 
-#' Register a parser to a name for use with the `@parser` tag
+#' Register or fetch a parser
 #'
 #' plumber2 comes with many parsers that should cover almost all standard
 #' use cases. Still you might want to provide some of your own, which this
 #' function facilitates.
 #'
+#' If you want to register your own parser, then the function you register must
+#' be a factory function, ie. a function returning a function. The returned
+#' function must accept two arguments, the first being a raw vector
+#' corresponding to the request body, the second being the parsed directives
+#' from the request `Content-Type` header. All arguments to the factory function
+#' should be optional.
+#'
 #' @param name The name to register the parser function to. If already
 #' present the current parser will be overwritten by the one provided by you
 #' @param fun A function that, when called, returns a binary function that can
@@ -15,19 +22,114 @@ registry$parsers <- list()
 #' @param mime_types One or more mime types that this parser can handle. The
 #' mime types are allowed to contain wildcards, e.g. `"text/*"`
 #'
-#' @return This function is called for its side effects
+#' @return For `get_parsers` a named list of parser functions named by their
+#' mime types. The order given in `parsers` is preserved.
 #'
+#' @seealso [parsers]
 #' @seealso [register_serializer()]
 #' @export
 #'
 register_parser <- function(name, fun, mime_types) {
   check_function(fun)
   check_character(mime_types)
+  check_string(name)
+  if (grepl("/", name, fixed = TRUE)) {
+    cli::cli_abort(
+      "{.arg name} must not contain the forward slash character ({.field /})"
+    )
+  }
+  if (name %in% c("...", "none")) {
+    cli::cli_abort(
+      "{.arg name} must not be {.val {c('...', 'none')}}"
+    )
+  }
   registry$parsers[[name]] <- list(fun = fun, types = mime_types)
   invisible(NULL)
 }
 
-get_parsers <- function(types = NULL, env = caller_env()) {
+#' @rdname register_parser
+#' @param parsers Parsers to collect. This can either be a character vector of
+#' names of registered parsers or a list. If it is a list then the following
+#' expectations apply:
+#' * Any unnamed elements containing a character vector will be considered as
+#'   names of registered parsers constructed with default values. The special
+#'   value `"..."` will fetch all the parsers that are otherwise not specified
+#'   in the call
+#' * Any element containing a function are considered as a provided parser and
+#'   the element must be named by the mime type the parser understands
+#'   (wildcards allowed)
+#' * Any remaining named elements will be considered names of registered parsers
+#'   that should be constructed with the arguments given in the element
+#'
+#' @export
+get_parsers <- function(parsers = NULL) {
+  if (is.null(parsers)) {
+    parsers <- names(registry$parsers)
+  }
+  elem_names <- names(parsers) %||% rep_along(parsers, "")
+  named_parsers <- unlist(lapply(seq_along(parsers), function(i) {
+    if (elem_names[i] == "") {
+      if (is_character(parsers[[i]])) {
+        parsers[[i]]
+      } else {
+        NULL
+      }
+    } else {
+      elem_names[i]
+    }
+  }))
+  if (sum(named_parsers == "...") > 1) {
+    cli::cli_abort("{.val ...} can only be used once in {.arg parsers}")
+  }
+  named_parsers <- named_parsers[!grepl("/|^\\.\\.\\.$", named_parsers)]
+  dots_parsers <- setdiff(names(registry$parsers), named_parsers)
+  parsers <- lapply(seq_along(parsers), function(i) {
+    if (is_function(parsers[[i]])) {
+      if (length(fn_fmls(parsers[[i]])) != 2) {
+        cli::cli_abort(
+          "Provided parsers must be binary functions"
+        )
+      }
+      if (!grepl("/", elem_names[i], fixed = TRUE)) {
+        cli::cli_abort(
+          "Parsers provided as functions must be named by their mime type"
+        )
+      }
+      return(list2(!!elem_names[i] := parsers[[i]]))
+    }
+    if (elem_names[i] == "" && is_character(parsers[[i]])) {
+      if (any(grepl("/", parsers[[i]], fixed = TRUE))) {
+        cli::cli_abort("mime types must be provided with a function")
+      }
+      return(get_parsers_internal(
+        parsers[[i]],
+        env = env,
+        dots_parsers = dots_parsers
+      ))
+    }
+    if (elem_names[i] != "") {
+      if (is.null(registry$parsers[[elem_names[i]]])) {
+        cli::cli_abort(
+          "No parser registered with {.val {elem_names[i]}} as name"
+        )
+      }
+      if (!is.list(parsers[[i]])) parsers[[i]] <- list(parsers[[i]])
+      funs <- rep_named(
+        registry$parsers[[elem_names[i]]]$types,
+        list(registry$parsers[[elem_names[i]]]$fun)
+      )
+      return(lapply(funs, function(f) inject(f(!!!parsers[[i]]))))
+    }
+    cli::cli_abort("Don't know how to parse element {i} in {.arg parsers}")
+  })
+  unlist(parsers, recursive = FALSE)
+}
+
+get_parsers_internal <- function(
+  types = NULL,
+  env = caller_env(),
+  dots_parsers = NULL
+) {
   if (isTRUE(tolower(types) == "none")) {
     return(NULL)
   }
@@ -38,19 +140,19 @@ get_parsers <- function(types = NULL, env = caller_env()) {
   if (length(dots) != 0) {
     types <- c(
       types[seq_len(dots - 1)],
-      setdiff(names(registry$parsers), types),
+      dots_parsers %||% setdiff(names(registry$parsers), types),
       types[dots + seq_len(length(types) - dots)]
     )
   }
   parsers <- lapply(types, function(type) {
     type <- stringi::stri_split_fixed(type, " ", n = 2)[[1]]
     if (stringi::stri_count_fixed(type[[1]], "/") == 1) {
       parser_fun <- if (length(type) == 2)
-        eval_bare(parse_expr(type[2]), env = env) else identity
+        eval_bare(parse_expr(type[2]), env = env) else function(x, ...) x
       check_function(parser_fun)
       parser <- list(
         fun = parser_fun,
-        type = type[1]
+        types = type[1]
       )
     } else {
       parser <- registry$parsers[[type[[1]]]]
@@ -82,51 +184,132 @@ get_parsers <- function(types = NULL, env = caller_env()) {
 }
 
 # Default parsers --------------------------------------------------------------
+
+#' Parser functions provided by plumber2
+#'
+#' These functions cover a large area of potential request body formats. They
+#' are all registered to their standard mime types but users may want to use
+#' them to register them to alternative types if they know it makes sense.
+#'
+#' # Provided parsers
+#' * `parse_csv()` uses [readr::read_csv()] for parsing. It is registered as
+#'   `"csv"` for the mime types `application/csv`, `application/x-csv`,
+#'   `text/csv`, and `text/x-csv`
+#' * `parse_octet()` passes the raw data through unchanged. It is registered as
+#'   `"octet"` for the mime type `application/octet-stream`
+#' * `parse_rds()` uses [unserialize()] for parsing. It is registered as
+#'   `"rds"` for the mime type `application/rds`
+#' * `parse_feather()` uses [arrow::read_feather()] for parsing. It is
+#'   registered as `"feather"` for the mime types
+#'   `application/vnd.apache.arrow.file` and `application/feather`
+#' * `parse_parquet()` uses [arrow::read_parquet()] for parsing. It is
+#'   registered as `"parquet"` for the mime type `application/vnd.apache.parquet`
+#' * `parse_text()` uses [rawToChar()] for parsing. It is registered as
+#'   `"text"` for the mime types `text/plain` and `text/*`
+#' * `parse_tsv()` uses [readr::read_tsv()] for parsing. It is registered as
+#'   `"tsv"` for the mime types `application/tab-separated-values` and
+#'   `text/tab-separated-values`
+#' * `parse_yaml()` uses [yaml::yaml.load()] for parsing. It is registered as
+#'   `"yaml"` for the mime types `text/vnd.yaml`, `application/yaml`,
+#'   `application/x-yaml`, `text/yaml`, and `text/x-yaml`
+#' * `parse_geojson()` uses [geojsonsf::geojson_sf()] for parsing. It is
+#'   registered as `"geojson"` for the mime types `application/geo+json` and
+#'   `application/vdn.geo+json`
+#'
+#' ## Additional registered parsers
+#' * [reqres::parse_json()] is registered as "`json`" for the mime types
+#'   `application/json` and `text/json`
+#' * [reqres::parse_multiform()] is registered as "`multi`" for the mime
+#'   type `multipart/*`
+#' * [reqres::parse_queryform()] is registered as "`form`" for the mime type
+#'   `application/x-www-form-urlencoded`
+#'
+#' @param ... Further argument passed on to the internal parsing function. See
+#' Details for information on which function handles the parsing internally in
+#' each parser
+#'
+#' @return A function accepting a raw vector along with a `directives` argument
+#' that provides further directives from the `Content-Type` to be passed along
+#'
+#' @seealso [register_parser()]
+#' @rdname parsers
+#' @name parsers
+#'
+NULL
+
+#' @rdname parsers
+#' @export
+#'
 parse_csv <- function(...) {
   check_installed("readr")
   function(raw, directives) {
     readr::read_csv(raw, ...)
   }
 }
+#' @rdname parsers
+#' @export
+#'
 parse_octet <- function() {
   function(raw, directives) {
     raw
   }
 }
+#' @rdname parsers
+#' @export
+#'
 parse_rds <- function(...) {
   function(raw, directives) {
     unserialize(raw, ...)
   }
 }
+#' @rdname parsers
+#' @export
+#'
 parse_feather <- function(...) {
   check_installed("arrow")
   function(raw, directives) {
     arrow::read_feather(raw, ...)
   }
 }
+#' @rdname parsers
+#' @export
+#'
 parse_parquet <- function(...) {
   check_installed("arrow")
   function(raw, directives) {
     arrow::read_parquet(raw, ...)
   }
 }
+#' @rdname parsers
+#' @inheritParams base::rawToChar
+#' @export
+#'
 parse_text <- function(multiple = FALSE) {
   function(raw, directives) {
     rawToChar(raw, multiple = multiple)
   }
 }
+#' @rdname parsers
+#' @export
+#'
 parse_tsv <- function(...) {
   check_installed("readr")
   function(raw, directives) {
     readr::read_tsv(raw, ...)
   }
 }
+#' @rdname parsers
+#' @export
+#'
 parse_yaml <- function(...) {
   check_installed("yaml")
   function(raw, directives) {
     yaml::yaml.load(rawToChar(raw), eval.expr = FALSE, ...)
   }
 }
+#' @rdname parsers
+#' @export
+#'
 parse_geojson <- function(...) {
   check_installed("geojsonsf")
   function(raw, directives) {