Content-Encoding: gzip for large enough request bodies

DESCRIPTION

@@ -42,7 +42,7 @@ Suggests:
 VignetteBuilder: knitr
 Language: en-US
 Encoding: UTF-8
-RoxygenNote: 6.1.0
+RoxygenNote: 6.1.1
 Roxygen: list(markdown = TRUE)
 LazyData: true
 Collate:

NEWS.md

@@ -4,6 +4,7 @@
 * Support for `"."` as a folder path/segment, referencing the current folder. `cd(project, ".")` returns `project`; `mv(project, ds, ".")` moves `ds` into `project`.
 * Fix bug in printing folders that contain entities with excessively long names
 * Improved speed for calculating insertions (subtotals, headers, etc.) on large cubes (speed ups of ~25x on large, realistic cubes).
+* Use `gzip` compression of request bodies larger than 1MB for faster transmission over the network.
 * First draft support for deck creation and manipulation.
 
 # crunch 1.24.2

R/api.R

@@ -1,22 +1,44 @@
 #' Main Crunch API handling function
 #' @param http.verb character in GET, PUT, POST, PATCH, DELETE
 #' @param url character URL to do the verb on
-#' @param ... additional arguments passed to `GET`, `PUT`,
-#' `POST`, `PATCH`, or `DELETE`
 #' @param config list of config parameters. See httr documentation.
+#' @param body request body. See httr documentation.
+#' @param encode How to encode `body` if it is a named list. Unlike in `httr`,
+#' the default is `"json"`.
 #' @param status.handlers named list of specific HTTP statuses and a response
 #' function to call in the case where that status is returned. Passed to the
 #' [handleAPIresponse()] function.
+#' @param ... additional arguments passed to `GET`, `PUT`,
+#' `POST`, `PATCH`, or `DELETE`
 #' @keywords internal
-crunchAPI <- function(http.verb, url, config = list(), status.handlers = list(), ...) {
+crunchAPI <- function(http.verb,
+                      url,
+                      config = list(),
+                      body = NULL,
+                      encode = "json",
+                      status.handlers = list(),
+                      ...) {
     url ## force lazy eval of url
     if (isTRUE(getOption("crunch.debug"))) {
         ## TODO: work this into httpcache.log
-        payload <- list(...)$body
-        if (!is.null(payload)) try(cat("\n", payload, "\n"), silent = TRUE)
+        if (!is.null(body)) try(cat("\n", body, "\n"), silent = TRUE)
     }
     FUN <- get(http.verb, envir = asNamespace("httpcache"))
-    x <- FUN(url, ..., config = c(get_crunch_config(), config))
+    baseconfig <- get_crunch_config()
+    if (!is.null(body) && encode == "json") {
+        # TODO: push the toJSON to here?
+        baseconfig <- c(baseconfig, add_headers(`Content-Type`="application/json"))
+        if (object.size(body) > getOption("crunch.min.gzip.bytes", 1024L)) {
+            # Compress. But only compress above a minimum threshold because
+            # gzip can make small objects a little bigger,
+            # + compression/decompression overhead.
+            # getOption makes this configurable for tests and also to provide a
+            # way to turn it off in case of emergency.
+            body <- memCompress(body, "gzip")
+            baseconfig <- c(baseconfig, add_headers(`Content-Encoding`="gzip"))
+        }
+    }
+    x <- FUN(url, ..., body = body, encode = encode, config = c(baseconfig, config))
     out <- handleAPIresponse(x, special.statuses = status.handlers)
     return(out)
 }

R/batches.R

@@ -50,7 +50,9 @@ createSource <- function(file, url, ...) {
     if (!missing(file)) {
         if (file.exists(file)) {
             u <- crPOST(sources_url,
-                body = list(uploaded_file = upload_file(file)), ...
+                body = list(uploaded_file = upload_file(file)),
+                encode = "multipart",
+                ...
             )
         } else {
             halt("File not found")

R/projects.R

@@ -82,7 +82,8 @@ icon <- function(x) {
 #' @export
 `icon<-` <- function(x, value) {
     crPUT(shojiURL(x, "views", "icon"),
-        body = list(icon = upload_file(value))
+        body = list(icon = upload_file(value)),
+        encode = "multipart"
     )
     dropOnly(absoluteURL("../", self(x))) ## Invalidate catalog
     return(refresh(x))

inst/crunch-test.R

@@ -79,6 +79,7 @@ cubify <- function(..., dims) {
 with_mock_crunch <- function(expr) {
     opts <- temp.options(
         crunch.api = "https://app.crunch.io/api/",
+        crunch.min.gzip.bytes = 1e9, ## Don't gzip request bodies in tests (until httptest can handle)
         httptest.mock.paths = c(".", "../inst/", system.file(package = "crunch"))
     )
     with(

tests/testthat/test-api.R

@@ -79,6 +79,25 @@ with_mock_crunch({
         expect_true(featureFlag("this_is_on"))
         expect_false(featureFlag("this_is_off"))
     })
+
+    test_that("Request bodies are gzipped (if large enough)", {
+        with(temp.option(crunch.min.gzip.bytes=0), {
+            expect_header(
+                expect_error( # httptest errors printing the gzipped body
+                # expect_POST(
+                    crPOST("https://app.crunch.io/api/", body = '{"value":1}')
+                ),
+                "Content-Encoding: gzip"
+            )
+        })
+    })
+
+    test_that("Other request headers", {
+        uncached({ # So we go to httr for these and not read cached responses
+            expect_header(crGET("https://app.crunch.io/api/"),
+                "User-Agent.*rcrunch", ignore.case=TRUE)
+        })
+    })
 })
 
 test_that("retry", {
@@ -96,29 +115,25 @@ test_that("retry", {
     )
 })
 
+test_that("crunchUserAgent", {
+    expect_true(grepl("rcrunch", crunchUserAgent()))
+    expect_true(grepl("libcurl", crunchUserAgent()))
+    expect_error(
+        crunchUserAgent("anotherpackage/3.1.4"),
+        NA
+    )
+    expect_true(grepl("anotherpackage", crunchUserAgent("anotherpackage")))
+})
+
 if (run.integration.tests) {
-    test_that("Request headers", {
+    test_that("Requests send Accept-Encoding: gzip", {
+        # libcurl adds this according to CURLOPT_ACCEPT_ENCODING, which appears
+        # to be on by default. expect_header() can't catch this because it gets
+        # added below httr, so we can't test this with mocks
         skip_if_disconnected()
         r <- crGET("http://httpbin.org/gzip")
         expect_true(r$gzipped)
         expect_true(grepl("gzip", r$headers[["Accept-Encoding"]]))
-        expect_true(grepl("rcrunch", r$headers[["User-Agent"]]))
-    })
-
-    test_that("crunchUserAgent", {
-        expect_true(grepl("rcrunch", crunchUserAgent()))
-        expect_true(grepl("libcurl", crunchUserAgent()))
-        expect_error(
-            crunchUserAgent("anotherpackage/3.1.4"),
-            NA
-        )
-        expect_true(grepl("anotherpackage", crunchUserAgent("anotherpackage")))
-    })
-
-    with_test_authentication({
-        test_that("API root can be fetched", {
-            expect_true(is.shojiObject(getAPIRoot()))
-        })
     })
 
     test_that("API calls throw an error if user is not authenticated", {

vignettes/crunch.Rmd

@@ -16,6 +16,7 @@ library(crunch)
 
 ```{r, results='hide', include = FALSE}
 library(httptest)
+options(crunch.min.gzip.bytes = 1e9) ## Don't gzip request bodies in tests (until httptest can handle))
 start_vignette("crunch")
 login()
 ```