Add yaml support (#556)

Co-authored-by: Bruno Tremblay <meztez@neoxone.com>
Co-authored-by: Barret Schloerke <barret@rstudio.com>

DESCRIPTION

@@ -41,7 +41,8 @@ Suggests:
     visNetwork,
     analogsea (>= 0.7.0),
     later,
-    readr
+    readr,
+    yaml
 Remotes:
     rstudio/swagger
 Collate:
@@ -74,6 +75,7 @@ Collate:
     'serializer-htmlwidget.R'
     'serializer-rds.R'
     'serializer-xml.R'
+    'serializer-yaml.R'
     'serializer.R'
     'session-cookie.R'
     'swagger.R'

NAMESPACE

@@ -22,6 +22,7 @@ export(parser_octet)
 export(parser_query)
 export(parser_rds)
 export(parser_text)
+export(parser_yaml)
 export(plumb)
 export(plumber)
 export(randomCookieKey)
@@ -32,6 +33,7 @@ export(serializer_htmlwidget)
 export(serializer_json)
 export(serializer_rds)
 export(serializer_unboxed_json)
+export(serializer_yaml)
 export(sessionCookie)
 import(R6)
 import(crayon)

NEWS.md

@@ -48,6 +48,8 @@ plumber 0.5.0
 
 ### New features
 
+* Add yaml support, serializer and parser. (@meztez, #556)
+
 * Added Swagger support for array parameters using syntax `name:[type]` and new type `list` (synonym df, data.frame). (@meztez, #532) 
 
 * Added support for promises in endpoints, filters, and hooks. (#248)

R/post-parsers.R

@@ -29,7 +29,7 @@ NULL
 #' to build parser are `value`, `content_type` and `filename` (only available
 #' in `multipart-form` body).
 #' ```r
-#' parser <- function(...) {
+#' parser <- function() {
 #'   function(value, content_type = "ct", filename, ...) {
 #'     # do something with raw value
 #'   }
@@ -40,7 +40,7 @@ NULL
 #' plumber endpoint function args.
 #'
 #' @examples
-#' parser_json <- function(...) {
+#' parser_json <- function() {
 #'   function(value, content_type = "application/json", ...) {
 #'     charset <- getCharacterSet(content_type)
 #'     value <- rawToChar(value)
@@ -68,9 +68,8 @@ addParser <- function(name, parser, pattern = NULL) {
 
 #' JSON
 #' @rdname parsers
-#' @param ... Raw values and headers are passed there.
 #' @export
-parser_json <- function(...) {
+parser_json <- function() {
   function(value, content_type = NULL, ...) {
     charset <- getCharacterSet(content_type)
     value <- rawToChar(value)
@@ -85,7 +84,7 @@ parser_json <- function(...) {
 #' QUERY STRING
 #' @rdname parsers
 #' @export
-parser_query <- function(...) {
+parser_query <- function() {
   function(value, content_type = NULL, ...) {
     charset <- getCharacterSet(content_type)
     value <- rawToChar(value)
@@ -100,7 +99,7 @@ parser_query <- function(...) {
 #' TEXT
 #' @rdname parsers
 #' @export
-parser_text <- function(...) {
+parser_text <- function() {
   function(value, content_type = NULL, ...) {
     charset <- getCharacterSet(content_type)
     value <- rawToChar(value)
@@ -115,7 +114,7 @@ parser_text <- function(...) {
 #" RDS
 #' @rdname parsers
 #' @export
-parser_rds <- function(...) {
+parser_rds <- function() {
   function(value, filename, ...) {
     tmp <- tempfile("plumb", fileext = paste0("_", basename(filename)))
     on.exit(file.remove(tmp), add = TRUE)
@@ -131,7 +130,7 @@ parser_rds <- function(...) {
 #' @rdname parsers
 #' @export
 #' @importFrom webutils parse_multipart
-parser_multi <- function(...) {
+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)
@@ -152,9 +151,8 @@ parser_multi <- function(...) {
 
 #' OCTET
 #' @rdname parsers
-#' @param ... Raw values and headers are passed there.
 #' @export
-parser_octet <- function(...) {
+parser_octet <- function() {
   function(value, filename = NULL, ...) {
     attr(value, "filename") <- filename
     return(value)
@@ -164,11 +162,30 @@ parser_octet <- function(...) {
 
 
 
+#' YAML
+#' @rdname parsers
+#' @export
+parser_yaml <- function() {
+  if (!requireNamespace("yaml", quietly = TRUE)) {
+    stop("yaml must be installed for the yaml parser to work")
+  }
+  function(value, content_type = NULL, ...) {
+    charset <- getCharacterSet(content_type)
+    value <- rawToChar(value)
+    Encoding(value) <- charset
+    yaml::yaml.load(value)
+  }
+}
+
+
+
+
 addParsers_onLoad <- function() {
   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")
+  addParser("yaml", parser_yaml, "application/x-yaml")
 }

R/serializer-yaml.R

@@ -0,0 +1,21 @@
+#' @rdname serializers
+#' @export
+serializer_yaml <- function(...) {
+  if (!requireNamespace("yaml", quietly = TRUE)) {
+    stop("yaml must be installed for the yaml serializer to work")
+  }
+  function(val, req, res, errorHandler) {
+    tryCatch({
+      yaml <- yaml::as.yaml(val, ...)
+      res$setHeader("Content-Type", "application/x-yaml")
+      res$body <- yaml
+
+      return(res$toResponse())
+    }, error = function(e){
+      errorHandler(req, res, e)
+    })
+  }
+}
+
+#' @include globals.R
+.globals$serializers[["yaml"]] <- serializer_yaml

tests/testthat/test-postbody.R

@@ -49,6 +49,13 @@ test_that("Test text parser", {
   expect_equal(parseBody("Ceci est un texte.", "text/html"), "Ceci est un texte.")
 })
 
+test_that("Test yaml parser", {
+  skip_if_not_installed("yaml")
+
+  r_object <- list(a=1,b=list(c=2,d=list(e=3,f=4:6)))
+  expect_equal(parseBody(charToRaw(yaml::as.yaml(r_object)), "application/x-yaml"), r_object)
+})
+
 test_that("Test multipart parser", {
 
   bin_file <- test_path("files/multipart-form.bin")

tests/testthat/test-serializer-yaml.R

@@ -0,0 +1,36 @@
+context("YAML serializer")
+
+test_that("YAML serializes properly", {
+  skip_if_not_installed("yaml")
+
+  l <- list(a=1, b=2, c="hi")
+  val <- serializer_yaml()(l, list(), PlumberResponse$new(), stop)
+  expect_equal(val$status, 200L)
+  expect_equal(val$headers$`Content-Type`, "application/x-yaml")
+  expect_equal(val$body, yaml::as.yaml(l))
+
+  l <- list(a=1, b=2, c="hi", na=NA)
+  val <- serializer_yaml()(l, list(), PlumberResponse$new(), stop)
+  expect_equal(val$status, 200L)
+  expect_equal(val$headers$`Content-Type`, "application/x-yaml")
+  expect_equal(val$body, yaml::as.yaml(l))
+
+  l <- list(a=1, b=2, c="hi", na=NA)
+  val <- serializer_yaml(indent = 4)(l, list(), PlumberResponse$new(), stop)
+  expect_equal(val$status, 200L)
+  expect_equal(val$headers$`Content-Type`, "application/x-yaml")
+  expect_equal(val$body, yaml::as.yaml(l, indent = 4))
+})
+
+test_that("Errors call error handler", {
+  skip_if_not_installed("yaml")
+
+  errors <- 0
+  errHandler <- function(req, res, err){
+    errors <<- errors + 1
+  }
+
+  expect_equal(errors, 0)
+  serializer_yaml()(parse(text="hi"), list(), PlumberResponse$new("yaml"), err = errHandler)
+  expect_equal(errors, 1)
+})