Handle HTTP redirects

R/http-libcurl.R

@@ -31,8 +31,9 @@ createCurlHandle <- function(timeout, certificate) {
   if (httpVerbose())
     curl::handle_setopt(handle, verbose = TRUE)
 
-  # turn off CURLOPT_FOLLOWLOCATION. the curl package makes this the default for new handles, but it
-  # causes a hang when attempting to follow some responses from shinyapps.io.
+  # suppress curl's automatically handling of redirects, since we have to
+  # handle ourselves in httpRequest()/httpRequestWithBody() due to our
+  # specialised auth needs
   curl::handle_setopt(handle, followlocation = FALSE)
 
   # return the newly created handle
@@ -78,40 +79,22 @@ httpLibCurl <- function(protocol,
     con <- file(contentFile, "rb")
     on.exit(if (!is.null(con)) close(con), add = TRUE)
 
-    if (identical(method, "POST")) {
-      # for POST operations, send all the file's content up at once. this is necessary because some
-      # POST endpoints return 3xx status codes, which require a seekfunction in order to replay the
-      # payload (the curl package does not currently allow specifying seekfunctions from R)
-      curl::handle_setopt(handle,
-                          post = TRUE,
-                          postfields = readBin(con,
-                                               what = "raw",
-                                               n = fileLength),
-                          postfieldsize_large = fileLength)
-    } else if (identical(method, "PUT")) {
-      # for PUT operations, which are often used for larger content (bundle uploads), stream the
-      # file from disk instead of reading it from memory
-      curl::handle_setopt(handle,
-                          upload = TRUE,
-                          infilesize_large = fileLength)
-
-      curl::handle_setopt(handle,
-        readfunction = function(nbytes, ...) {
-           if (is.null(con)) {
-             return(raw())
-           }
-           bin <- readBin(con, "raw", nbytes)
-           if (length(bin) < nbytes) {
-             close(con)
-             con <<- NULL
-           }
-           bin
-        })
-    } else {
-      # why was a file specified for this endpoint?
-      warning("Content file specified, but not used because the '", method, "' request ",
-              "type does not accept a body.")
-    }
+    curl::handle_setopt(
+      handle,
+      upload = TRUE,
+      infilesize_large = fileLength,
+      readfunction = function(nbytes, ...) {
+        if (is.null(con)) {
+          return(raw())
+        }
+        bin <- readBin(con, "raw", nbytes)
+        if (length(bin) < nbytes) {
+          close(con)
+          con <<- NULL
+        }
+        bin
+      }
+    )
   }
 
   # ensure we're using the requested method
@@ -122,19 +105,10 @@ httpLibCurl <- function(protocol,
 
   # make the request
   response <- NULL
-  time <- system.time(gcFirst = FALSE, tryCatch({
-      # fetch the response into a raw buffer in memory
-      response <- curl::curl_fetch_memory(url, handle = handle)
-    },
-    error = function(e, ...) {
-      # ignore errors resulting from timeout or user abort
-      if (identical(e$message, "Callback aborted") ||
-          identical(e$message, "transfer closed with outstanding read data remaining"))
-        return(NULL)
-      # bubble remaining errors through
-      else
-        stop(e)
-    }))
+  time <- system.time(
+    response <- curl::curl_fetch_memory(url, handle = handle),
+    gcFirst = FALSE
+  )
   httpTrace(method, path, time)
 
   # get list of HTTP response headers

R/http.R

@@ -33,6 +33,21 @@ httpRequest <- function(service,
     timeout = timeout,
     certificate = certificate
   )
+
+  while (httpResponse$status >= 300 && httpResponse$status < 400) {
+    service <- parseHttpUrl(httpResponse$location)
+    httpResponse <- http(
+      protocol = service$protocol,
+      host = service$host,
+      port = service$port,
+      method = method,
+      path = service$path,
+      headers = headers,
+      timeout = timeout,
+      certificate = certificate
+    )
+  }
+
   handleResponse(httpResponse, error_call = error_call)
 }
 
@@ -60,7 +75,7 @@ httpRequestWithBody <- function(service,
   }
 
   path <- buildPath(service$path, path, query)
-  headers <- c(headers, authHeaders(authInfo, method, path, file))
+  authed_headers <- c(headers, authHeaders(authInfo, method, path, file))
   certificate <- requestCertificate(service$protocol, authInfo$certificate)
 
   # perform request
@@ -71,18 +86,35 @@ httpRequestWithBody <- function(service,
     port = service$port,
     method = method,
     path = path,
-    headers = headers,
+    headers = authed_headers,
     contentType = contentType,
     contentFile = file,
     certificate = certificate
   )
+  while (httpResponse$status >= 300 && httpResponse$status < 400) {
+    # This is a simplification of the spec, since we should preserve
+    # the method for 307 and 308
+    # https://www.rfc-editor.org/rfc/rfc9110.html#name-redirection-3xx
+    service <- parseHttpUrl(httpResponse$location)
+    authed_headers <- c(headers, authHeaders(authInfo, "GET", service$path))
+    httpResponse <- http(
+      protocol = service$protocol,
+      host = service$host,
+      port = service$port,
+      method = "GET",
+      path = service$path,
+      headers = authed_headers,
+      certificate = certificate
+    )
+    httpResponse
+  }
+
   handleResponse(httpResponse, error_call = error_call)
 }
 
 handleResponse <- function(response, error_call = caller_env()) {
   reportError <- function(msg) {
-    req <- response$req
-    url <- paste0(req$protocol, "://", req$host, req$port, req$path)
+    url <- buildHttpUrl(response$req)
 
     cli::cli_abort(
       c("<{url}> failed with HTTP status {response$status}", msg),
@@ -295,6 +327,10 @@ parseHttpUrl <- function(urlText) {
   url
 }
 
+buildHttpUrl <- function(x) {
+  paste0(x$protocol, "://", x$host, x$port, x$path)
+}
+
 urlDecode <- function(x) {
   curl::curl_unescape(x)
 }
@@ -355,6 +391,7 @@ authHeaders <- function(authInfo, method, path, file = NULL) {
   }
 }
 
+# https://github.com/rstudio/connect/wiki/token-authentication#request-signing-rsconnect
 signatureHeaders <- function(authInfo, method, path, file = NULL) {
   # headers to return
   headers <- list()

R/ide.R

@@ -17,84 +17,45 @@ validateServerUrl <- function(url, certificate = NULL) {
 # The URL may be specified with or without the protocol and port; this function
 # will try both http and https and follow any redirects given by the server.
 validateConnectUrl <- function(url, certificate = NULL) {
-  tryAllProtocols <- TRUE
-
-  if (!grepl("://", url, fixed = TRUE))
-  {
+  # Add protocol if missing, assuming https except for local installs
+  if (!grepl("://", url, fixed = TRUE)) {
     if (grepl(":3939", url, fixed = TRUE)) {
-      # assume http for default (local) connect installations
       url <- paste0("http://", url)
     } else {
-      # assume https elsewhere
       url <- paste0("https://", url)
     }
   }
-
-  # if the URL ends with a port number, don't try http/https on the same port
-  if (grepl(":\\d+/?$", url)) {
-    tryAllProtocols <- FALSE
-  }
-
-  settingsEndpoint <- "/server_settings"
   url <- ensureConnectServerUrl(url)
+  is_http <- grepl("^http://", url)
+
+  GET_server_settings <- function(url) {
+    auth_info <- list(certificate = inferCertificateContents(certificate))
+    GET(
+      parseHttpUrl(url),
+      auth_info,
+      "/server_settings",
+      timeout = getOption("rsconnect.http.timeout", 10)
+    )
+  }
 
-  # populate certificate if supplied
-  certificate <- inferCertificateContents(certificate)
-
-  # begin trying URLs to discover the correct one
   response <- NULL
-  errMessage <- ""
-  retry <- TRUE
-  while (retry) {
-    tryCatch({
-      response <- GET(parseHttpUrl(url),
-                          list(certificate = certificate),
-                          settingsEndpoint,
-                          timeout = getOption("rsconnect.http.timeout", 10))
-
-      httpResponse <- attr(response, "httpResponse")
-      # check for redirect
-      if (httpResponse$status == 307 &&
-          !is.null(httpResponse$location)) {
-
-        # we were served a redirect; try again with the new URL
-        url <- httpResponse$location
-        if (substring(url, (nchar(url) - nchar(settingsEndpoint)) + 1)   ==
-            settingsEndpoint) {
-          # chop /server_settings from the redirect path to get the raw API path
-          url <- substring(url, 1, nchar(url) - nchar(settingsEndpoint))
-        }
-        next
-      }
-      if (!isContentType(httpResponse, "application/json")) {
-        response <- NULL
-        errMessage <- "Endpoint did not return JSON"
-      }
+  cnd <- catch_cnd(response <- GET_server_settings(url), "error")
+  if (is_http && cnd_inherits(cnd, "OPERATION_TIMEDOUT")) {
+    url <- gsub("^http://", "https://", url)
+    cnd <- catch_cnd(response <- GET_server_settings(url), "error")
+  }
 
-      # got a real response; stop trying now
-      retry <- FALSE
-    }, error = function(e) {
-      if (inherits(e, "OPERATION_TIMEDOUT") && tryAllProtocols) {
-        # if the operation timed out on one protocol, try the other one (note
-        # that we don't do this if a port is specified)
-        if (substring(url, 1, 7) == "http://") {
-          url <<- paste0("https://", substring(url, 8))
-        } else if (substring(url, 1, 8) == "https://") {
-          url <<- paste0("http://", substring(url, 9))
-        }
-        tryAllProtocols <<- FALSE
-        return()
-      }
-      errMessage <<- e$message
-      retry <<- FALSE
-    })
+  if (!is.null(cnd)) {
+    return(list(valid = FALSE, message = conditionMessage(cnd)))
   }
 
-  if (is.null(response)) {
-    list(valid = FALSE, message = errMessage)
-  } else {
-    list(valid = TRUE, url = url, response = response)
+  httpResponse <- attr(response, "httpResponse")
+  if (!isContentType(httpResponse, "application/json")) {
+    return(list(valid = FALSE, message = "Endpoint did not return JSON"))
   }
+
+  url <- gsub("/server_settings$", "", buildHttpUrl(httpResponse$req))
+  list(valid = TRUE, url = url, response = response)
 }
 
 # given a server URL, returns that server's short name. if the server is not

tests/testthat/test-http-libcurl.R

@@ -7,22 +7,3 @@ test_that("basic HTTP methods work", {
   test_http_POST_file()
   test_http_headers()
 })
-
-test_that("can stream PUT content from disk", {
-  service <- httpbin_service()
-
-  path <- withr::local_tempfile()
-  con <- file(path, "wb")
-  writeLines(c("1", "2", "3"), con = con)
-  close(con)
-
-  resp <- PUT(
-    service,
-    authInfo = NULL,
-    path = "put",
-    contentType = "text/plain",
-    file = path
-  )
-  expect_equal(attr(resp, "httpResponse")$status, 200)
-  expect_equal(resp$data, "1\n2\n3\n")
-})

tests/testthat/test-ide.R

@@ -1,7 +1,7 @@
 test_that("validateConnectUrl() returns expected return for some known endpoints", {
 
-  expect_false(validateConnectUrl("http://posit.cloud")$valid)
-  expect_false(validateConnectUrl("http://shinyapps.io")$valid)
+  expect_false(validateConnectUrl("https://posit.cloud")$valid)
+  expect_false(validateConnectUrl("https://shinyapps.io")$valid)
   expect_true(validateConnectUrl("https://connect.rstudioservices.com/")$valid)
   expect_true(validateConnectUrl("https://colorado.posit.co/rsc")$valid)
 })
@@ -12,3 +12,8 @@ test_that("validateConnectUrl() normalises urls", {
   expect_equal(validateConnectUrl("connect.rstudioservices.com")$url, api_url)
   expect_equal(validateConnectUrl("https://connect.rstudioservices.com/")$url, api_url)
 })
+
+test_that("validateConnectUrl() follows redirects", {
+  api_url <- "https://connect.rstudioservices.com:443/__api__"
+  expect_equal(validateConnectUrl("http://connect.rstudioservices.com")$url, api_url)
+})