R/http-internal.R

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

# Internal sockets HTTP transport. Not recommended since it does not support HTTPS, but useful as a
# last resort if other methods don't work since it can piggyback on IE proxy settings via R's own
# internet configuration.

httpInternal <- 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")

  # default port to 80 if necessary
  if (!nzchar(port))
    port <- "80"

  # read file in binary mode
  if (!is.null(contentFile)) {
    fileLength <- file.info(contentFile)$size
    fileContents <- readBin(contentFile, what = "raw", n = fileLength)
  }

  # build http request
  request <- NULL
  request <- c(request, paste(method, " ", path, " HTTP/1.1\r\n", sep = ""))
  request <- c(request, "User-Agent: ", userAgent(), "\r\n")
  request <- c(request, "Host: ", host, "\r\n", sep = "")
  request <- c(request, "Accept: */*\r\n")
  if (!is.null(contentFile)) {
    request <- c(request, paste("Content-Type: ",
                                contentType,
                                "\r\n",
                                sep = ""))
    request <- c(request, paste("Content-Length: ",
                                fileLength,
                                "\r\n",
                                sep = ""))
  }
  headers <- appendCookieHeaders(
    list(protocol = protocol, host = host, port = port, path = path), headers)
  for (name in names(headers))
  {
    request <- c(request,
                 paste(name, ": ", headers[[name]], "\r\n", sep = ""))
  }
  request <- c(request, "\r\n")

  # output request if in verbose mode
  if (httpVerbose())
    cat(request)

  # use timeout if supplied, default timeout if not (matches parameter behavior
  # for socketConnection)
  timeout <- if (is.null(timeout)) getOption("timeout") else timeout

  # open socket connection
  time <- system.time(gcFirst = FALSE, {
    conn <- socketConnection(host = host,
                             port = as.integer(port),
                             open = "w+b",
                             blocking = TRUE,
                             timeout = timeout)
    defer(close(conn))

    # write the request header and file payload
    writeBin(charToRaw(paste(request, collapse = "")), conn, size = 1)
    if (!is.null(contentFile)) {
      writeBin(fileContents, conn, size = 1)
    }

    # read the response
    response <- readHttpResponse(list(
        protocol = protocol,
        host     = host,
        port     = port,
        method   = method,
        path     = path),
      conn)
  })
  httpTrace(method, path, time)

  # print if in verbose mode
  if (httpVerbose())
    print(response)

  # output JSON if requested
  if (httpTraceJson() && identical(contentType, "application/json"))
    cat(paste0("<< ", rawToChar(fileContents), "\n"))

  # return it
  response
}