Implementation of request signing for Amazon's S3 in R.

s3.r

library(httr)
library(digest)
library(XML)

s3_request <- function(verb, bucket, path = "/", query = NULL,
                       content = NULL, date = NULL) {
  list(
    verb = verb,
    bucket = bucket,
    path = path,
    query = query,
    content = content,
    date = date
  )
}

timestamp <- function() {
  format(Sys.time(), "%a, %d %b %Y %H:%M:%S +0000", tz = "UTC")
}
"%||%" <- function(a, b) {
  if (!is.null(a)) a else b
}

make_request <- function(request, keys) {
  host <- paste0(request$bucket, ".s3.amazonaws.com")
  url <- modify_url(paste0("http://", host, request$path),
    query = request$query)

  request$date <- request$date %||% timestamp()
  headers <- list()
  headers$Authorization <- authorization(request, headers, keys)
  headers$Date <- request$date

  list(verb = request$verb, url = url, headers = headers)
}

do <- function(request, keys) {
  req <- make_request(request, keys)
  headers_c <- add_headers(.headers = unlist(req$headers))

  if (req$verb == "GET") {
    r <- GET(req$url, config = headers_c)
  } else {
    stop(req$verb, " verb not yet supported", call. = FALSE)
  }

  res <- content(r, "text")
  xml <- xmlTreeParse(res)$doc$children[[1]]

  if (r$status != 200) {
    err <- toString(getNodeSet(xml, "//Error//Message")[[1]][[1]])
    stop("Request failed with http code ", r$status, ": \n",
      paste(strwrap(err), collapse = "\n"), call. = FALSE)
  }

  xml
}

authorization <- function(request, headers, keys) {
  if (!is.null(request$content)) {
    content_md5 <- digest(request$content, "md5")
    content_type <- request$type
  } else {
    content_md5 <- ""
    content_type <- ""
  }

  resource_canoc <- paste0("/", request$bucket, request$path)

  names(headers) <- tolower(names(headers))
  headers <- headers[order(names(headers))]
  headers_canoc <- paste0(names(headers), ":", headers, "\n")

  string <- paste0(
    toupper(request$verb), "\n",
    content_md5, "\n",
    content_type, "\n",
    request$date,
    if (length(headers) > 0) headers_canoc else "\n",
    resource_canoc
  )

  signature <- hmac_sha1(keys$secret, string)
  paste0("AWS ", keys$access, ":", signature)
}

test <- list(
  access = "AKIAIOSFODNN7EXAMPLE",
  secret = "wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKEY")

r1 <- s3_request("GET", "johnsmith", "/photos/puppy.jpg",
  date = "Tue, 27 Mar 2007 19:36:42 +0000")
# make_request(r1, test)

keys <- list(
  access = Sys.getenv("AWS_KEY"),
  secret = Sys.getenv("AWS_SECRET_KEY"))

do(s3_request("GET", "data.had.co.nz"), keys)

@hadley @leeper pointed me to his work on cloudyr, which already has a nice implementation of the newer (V4) signatures for the AWS API: https://github.com/cloudyr . We'll see where we can go from there. Thanks again for all the nice stuff httr does to facilitate this!