The R Project SVN R

## Tests for HTTP headers -----------------------------------------------

is_online <- function() {
  tryCatch({
    con <- suppressWarnings(socketConnection("8.8.8.8", port = 53))
    close(con)
    con <- url("http://eu.httpbin.org/headers")
    lines <- readLines(con)
    close(con)
    stopifnot(any(grepl("Host.*eu.httpbin.org", lines)))
    TRUE
  }, error = function(e) FALSE)
}

get_headers <- function(path = "anything", quiet = TRUE, ...,
                        protocol = "http") {
  url <- get_path(path, protocol)
  tmp <-  tempfile()
  on.exit(try(unlink(tmp)), add = TRUE)
  download.file(url, tmp, quiet = quiet, ...)
  readLines(tmp)
}

get_headers_url <- function(path = "anything", ..., protocol = "http") {
  con <- url(get_path(path, protocol), ...)
  on.exit(try(close(con)), add = TRUE)
  readLines(con)
}

get_path <- function(path = "anything", protocol = "http") {
  paste0(protocol, "://", "eu.httpbin.org/", path)
}

with_options <- function(opts, expr) {
  old <- do.call(options, as.list(opts))
  on.exit(options(old), add = TRUE)
  expr
}

tests <- function() {
  cat("- User agent is still set\n")
  with_options(list(HTTPUserAgent = "foobar"), {
    h <- get_headers()
    stopifnot(any(grepl("User-Agent.*foobar", h)))
  })

  with_options(list(HTTPUserAgent = "foobar"), {
    h <- get_headers(headers = c(foo = "bar", zzzz = "bee"))
    stopifnot(any(grepl("User-Agent.*foobar", h)))
    stopifnot(any(grepl("Foo.*bar", h)))
    stopifnot(any(grepl("Zzzz.*bee", h)))
  })

  cat("- Can supply headers\n")
  h <- get_headers(headers = c(foo = "bar", zzzz = "bee"))
  stopifnot(any(grepl("Foo.*bar", h)))
  stopifnot(any(grepl("Zzzz.*bee", h)))

  cat("- Basic auth\n")
  ret <- tryCatch({
    h <- suppressWarnings(get_headers(
      "basic-auth/Aladdin/OpenSesame",
      headers = c(Authorization = "Basic QWxhZGRpbjpPcGVuU2VzYW1l")))
    TRUE
  }, error = function(e) FALSE)
  stopifnot(any(grepl("authenticated.*true", h)))

  if (getOption("download.file.method") == "libcurl") {
    cat("- Multiple urls (libcurl only)\n")
    urls <- get_path(c("anything", "headers"))
    tmp1 <- tempfile()
    tmp2 <- tempfile()
    on.exit(unlink(c(tmp1, tmp2)), add = TRUE)
    status <- download.file(urls, c(tmp1, tmp2), quiet = TRUE,
                            headers = c(foo = "bar", zzzz = "bee"))
    if (status == 0L) {
        h1 <- readLines(tmp1)
        h2 <- readLines(tmp2)
        stopifnot(any(grepl("Foo.*bar", h1)))
        stopifnot(any(grepl("Zzzz.*bee", h1)))
        stopifnot(any(grepl("Foo.*bar", h2)))
        stopifnot(any(grepl("Zzzz.*bee", h2)))
    }
  }

  cat("- HTTPS\n")
  h <- get_headers(headers = c(foo = "bar", zzzz = "bee"), protocol = "https")
  stopifnot(any(grepl("Foo.*bar", h)))
  stopifnot(any(grepl("Zzzz.*bee", h)))

  cat("- If headers not named, then error\n")
  ret <- tryCatch(
    download.file(get_path(), headers = c("foo", "xxx" = "bar")),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))
  ret <- tryCatch(
    download.file(get_path(), headers = "foobar"),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))

  cat("- If headers are NA, then error\n")
  ret <- tryCatch(
    download.file(get_path(), headers = c("foo" = NA, "xxx" = "bar")),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))
  ret <- tryCatch(
    download.file(
      get_path(), quiet = TRUE,
      headers = structure(c("foo", "bar", names = c("foo", NA)))),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))

  cat("- user agent is set in url()\n")
  with_options(list(HTTPUserAgent = "foobar"), {
    h <- get_headers_url()
    stopifnot(any(grepl("User-Agent.*foobar", h)))
  })

  cat("- file() still works with URLs\n")
  con <- file(get_path("anything", "http"))
  on.exit(close(con), add = TRUE)
  h <- readLines(con)
  stopifnot(any(grepl("Host.*eu.httpbin.org", h)))

  cat("- If headers not named, then url() errors\n")
  ret <- tryCatch(
    url(get_path(), headers = c("foo", "xxx" = "bar")),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))

  cat("- If headers are NA, then url() errors\n")
  ret <- tryCatch(
    url(get_path(), headers = c("foo" = "bar", "xxx" = NA)),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))
  ret <- tryCatch(
    url(get_path(),
        headers = structure(c("1", "2"), names = c("foo", NA))),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))

  cat("- Can supply headers in url()\n")
  h <- get_headers_url(headers = c(foo = "bar", zzzz = "bee"))
  stopifnot(any(grepl("Foo.*bar", h)))
  stopifnot(any(grepl("Zzzz.*bee", h)))

  cat("- HTTPS with url()\n")
  h <- get_headers_url(headers = c(foo = "bar", zzzz = "bee"),
                       protocol = "https")
  stopifnot(any(grepl("Foo.*bar", h)))
  stopifnot(any(grepl("Zzzz.*bee", h)))
}

main <- function() {
    if (capabilities("libcurl")) {
        cat("\nlibcurl method\n")
        with_options(c(download.file.method = "libcurl"), tests())
    }

    if (.Platform$OS.type == "windows")  {
        ## This is deprecated and will give warnings.
        cat("\nwininet method\n")
        with_options(c(download.file.method = "wininet"), tests())
    }
}

options(warn = 1)

if (is_online()) main()