R/http-curl.R

In rsconnect: Deploy Docs, Apps, and APIs to 'Posit Connect', 'shinyapps.io', and 'RPubs'

# HTTP transport using the curl command-line utility. Useful on systems that have a working curl but
# not necessarily a working curl library, such as Windows 10.

httpCurl <- function(
  protocol,
  host,
  port,
  method,
  path,
  headers,
  contentType = NULL,
  contentFile = NULL,
  certificate = NULL,
  timeout = NULL
) {
  if (!is.null(contentFile) && is.null(contentType)) {
    stop("You must specify a contentType for the specified file")
  }

  if (!is.null(contentFile)) {
    fileLength <- file.info(contentFile)$size
  }

  headers <- appendCookieHeaders(
    list(protocol = protocol, host = host, port = port, path = path),
    headers
  )
  extraHeaders <- character()
  for (header in names(headers)) {
    if (
      !identical(header, "Content-Type") && !identical(header, "Content-Length")
    ) {
      extraHeaders <- paste(extraHeaders, "--header")
      extraHeaders <- paste(
        extraHeaders,
        paste('"', header, ": ", headers[[header]], '"', sep = "")
      )
    }
  }

  outputFile <- tempfile()

  command <- paste("curl", "-i", "-X", method)

  if (httpVerbose()) {
    command <- paste(command, "-v")
  }

  if (!is.null(timeout)) {
    command <- paste(command, "--connect-timeout", timeout)
  }

  if (!is.null(contentFile)) {
    command <- paste(
      command,
      "-T",
      shQuote(contentFile),
      "--header",
      paste('"', "Content-Type: ", contentType, '"', sep = ""),
      "--header",
      paste('"', "Content-Length: ", fileLength, '"', sep = "")
    )
  }

  # add prefix to port if necessary
  if (nzchar(port)) {
    port <- paste(":", port, sep = "")
  }

  if (!isTRUE(getOption("rsconnect.check.certificate", TRUE))) {
    # suppressed certificate check
    command <- paste(command, "--insecure")
  } else if (!is.null(certificate)) {
    # cert check not suppressed and we have a supplied cert
    command <- paste(command, "--cacert", shQuote(certificate))
  }

  command <- paste(
    command,
    extraHeaders,
    "--header",
    "Expect:",
    "--user-agent",
    userAgent(),
    "--silent",
    "--show-error",
    "-o",
    shQuote(outputFile),
    paste('"', protocol, "://", host, port, path, '"', sep = "")
  )

  result <- NULL
  time <- system.time(gcFirst = FALSE, {
    result <- system(command)
  })
  httpTrace(method, path, time)

  # emit JSON trace if requested
  if (
    !is.null(contentFile) &&
      httpTraceJson() &&
      identical(contentType, "application/json")
  ) {
    fileLength <- file.info(contentFile)$size
    fileContents <- readBin(contentFile, what = "raw", n = fileLength)
    cat(paste0("<< ", rawToChar(fileContents), "\n"))
  }

  if (result == 0) {
    fileConn <- file(outputFile, "rb")
    defer(close(fileConn))
    readHttpResponse(
      list(
        protocol = protocol,
        host = host,
        port = port,
        method = method,
        path = path
      ),
      fileConn
    )
  } else {
    stop(paste("Curl request failed (curl error", result, "occurred)"))
  }
}