add serializer_rds and serializer_rds3

DESCRIPTION

@@ -66,6 +66,7 @@ Collate:
     'serializer-content-type.R'
     'serializer-html.R'
     'serializer-htmlwidget.R'
+    'serializer-rds.R'
     'serializer-xml.R'
     'serializer.R'
     'session-cookie.R'

NAMESPACE

@@ -20,6 +20,7 @@ export(serializer_content_type)
 export(serializer_html)
 export(serializer_htmlwidget)
 export(serializer_json)
+export(serializer_rds)
 export(serializer_unboxed_json)
 export(sessionCookie)
 import(R6)

R/serializer-content-type.R

@@ -1,7 +1,7 @@
 #' @rdname serializers
 #' @param type The value to provide for the `Content-Type` HTTP header.
 #' @export
-serializer_content_type <- function(type){
+serializer_content_type <- function(type) {
   if (missing(type)){
     stop("You must provide the custom content type to the serializer_content_type")
   }
@@ -17,4 +17,5 @@ serializer_content_type <- function(type){
   }
 }
 
+#' @include globals.R
 .globals$serializers[["contentType"]] <- serializer_content_type

R/serializer-html.R

@@ -13,4 +13,5 @@ serializer_html <- function() {
   }
 }
 
+#' @include globals.R
 .globals$serializers[["html"]] <- serializer_html

R/serializer-htmlwidget.R

@@ -1,4 +1,3 @@
-#' @include globals.R
 #' @rdname serializers
 #' @export
 serializer_htmlwidget <- function(...) {
@@ -35,4 +34,6 @@ serializer_htmlwidget <- function(...) {
   }
 }
 
+
+#' @include globals.R
 .globals$serializers[["htmlwidget"]] <- serializer_htmlwidget

R/serializer-json.R

@@ -1,4 +1,3 @@
-#' @include globals.R
 #' @rdname serializers
 #' @param ... extra arguments supplied to respective internal serialization function.
 #' @export
@@ -16,14 +15,14 @@ serializer_json <- function(...) {
     })
   }
 }
-.globals$serializers[["json"]] <- serializer_json
 
-#' @include globals.R
 #' @rdname serializers
 #' @inheritParams jsonlite::toJSON
 #' @export
 serializer_unboxed_json <- function(auto_unbox = TRUE, ...) {
   serializer_json(auto_unbox = auto_unbox, ...)
 }
 
+#' @include globals.R
+.globals$serializers[["json"]] <- serializer_json
 .globals$serializers[["unboxedJSON"]] <- serializer_unboxed_json

R/serializer-rds.R

@@ -0,0 +1,26 @@
+#' @rdname serializers
+#' @inheritParams base::serialize
+#' @export
+serializer_rds <- function(version = "2", ascii = FALSE, ...) {
+  if (identical(version, "3")) {
+    if (package_version(R.version) < "3.5") {
+      stop(
+        "R versions before 3.5 do not know how to serialize with `version = \"3\"`",
+        "\n Current R version: ", as.character(package_version(R.version))
+      )
+    }
+  }
+  function(val, req, res, errorHandler) {
+    tryCatch({
+      res$setHeader("Content-Type", "application/octet-stream")
+      res$body <- base::serialize(val, NULL, ascii = ascii, version = version, ...)
+      return(res$toResponse())
+    }, error = function(e){
+      errorHandler(req, res, e)
+    })
+  }
+}
+
+
+#' @include globals.R
+.globals$serializers[["rds"]] <- serializer_rds

tests/testthat/test-serializer-rds.R

@@ -0,0 +1,11 @@
+context("rds serializer")
+
+test_that("rds serializes properly", {
+  v <- iris[0,]
+  attr(v, "origin") <- iris
+  val <- serializer_rds()(v, list(), PlumberResponse$new(), stop)
+  expect_equal(val$status, 200L)
+  expect_equal(val$headers$`Content-Type`, "application/octet-stream")
+  expect_equal(val$body, serialize(v, NULL, ascii = FALSE))
+  expect_equal(unserialize(val$body), v)
+})