Nothing
### =========================================================================
### HTTP protocol implementation
### -------------------------------------------------------------------------
.HTTP <- setRefClass("HTTP",
fields = list(
accept = "character",
cookie = "character_OR_NULL",
insecure = "logical"
),
contains = "CRUDProtocol")
setClass("HTTPS", contains="HTTP")
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Constructor
###
HTTP <- function(accept = acceptedMediaTypes(), cookie = NULL,
insecure = FALSE)
{
if (!is.character(accept) || any(is.na(accept)))
stop("'accept' must be a character() without NAs")
if (!is.null(cookie) && !isSingleString(cookie))
stop("'cookie' must be a single string or NULL")
if (!isTRUEorFALSE(insecure))
stop("'insecure' must be a TRUE or FALSE")
.HTTP$new(accept = accept, cookie = cookie, insecure = insecure)
}
HTTPS <- HTTP
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### CRUD implementation
###
.HTTP$methods(create = function(x, value, ...) {
if (!isSingleString(x))
stop("'x' must be a single, non-NA string representing a URL")
curl <- getCurlHandle()
reader <- dynCurlReader(curl)
opts <- curlOptions(postfields = paste(value, collapse="\n"),
httpheader = c(
Accept = accept(.self),
'Content-Type' = contentType(value),
Authorization = authorization(x),
...),
headerfunction = reader$update,
cookie = .self$cookie,
ssl.verifyhost = !.self$insecure,
ssl.verifypeer = !.self$insecure,
followlocation = TRUE)
content <- try(postForm(x, .opts=opts, curl=curl), silent=TRUE)
invisible(handleResponse(content, reader, errorHandler = x@errorHandler))
})
.HTTP$methods(read = function(x, cache.info, ...) {
if (!isSingleString(x))
stop("'x' must be a single, non-NA string representing a URL")
request.header <- c(headerFromCacheInfo(cache.info),
Authorization = authorization(x),
Accept = accept(.self),
...)
## We use our own reader so that we can return the body in case of error
curl <- getCurlHandle(httpheader = request.header, cookie = .self$cookie,
ssl.verifyhost = !.self$insecure,
ssl.verifypeer = !.self$insecure,
followlocation = TRUE)
reader <- dynCurlReader(curl)
content <- try(getURLContent(x, header = reader, curl = curl), silent=TRUE)
handleResponse(content, reader, cache.info, x@errorHandler)
})
.HTTP$methods(update = function(x, ..., value) {
stop("PUT support not yet implemented")
})
.HTTP$methods(delete = function(x, ...) {
stop("DELETE support not yet implemented")
})
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Helpers
###
defaultErrorHandler <- function(response) {
stop(response$statusMessage)
}
handleResponse <- function(content, reader, cache.info = NULL,
errorHandler = defaultErrorHandler) {
response <- list(header = parseHTTPHeader(reader$header()),
body = reader$value())
status <- as.integer(response$header["status"])
statusMessage <- response$header["statusMessage"]
if (identical(status, HTTP_STATUS$Unauthorized)) {
unauthorized()
}
if (is(content, "try-error")) {
media <- responseToMedia(response)
body <- as(media, mediaTarget(media))
responseError <- list(status = status, statusMessage = statusMessage,
body = body)
errorHandler(responseError)
}
if (identical(status, HTTP_STATUS$No_Content)) {
response <- NULL
}
if (!is.null(cache.info) && identical(status, HTTP_STATUS$Not_Modified)) {
cacheInfoFromHeader(response$header, cache.info)
} else {
responseToMedia(response)
}
}
coercionTable <- function() {
signatures <- names(getMethods(coerce, table = TRUE))
matrix(unlist(strsplit(signatures, "#")), ncol=2L, byrow=TRUE,
dimnames=list(NULL, c("from", "to")))
}
mediaCoercionTable <- function() {
tab <- coercionTable()
classes <- names(getClass("Media")@subclasses)
tab[rowSums(matrix(tab %in% classes, ncol=2L)) == 1L,]
}
acceptedMediaTypes <- function() {
intersect(mediaCoercionTable()[,"from"],
names(getClass("Media")@subclasses))
}
responseToMedia <- function(x) {
content.type <- head(attr(x$body, "Content-Type"), 1)
content.params <- tail(attr(x$body, "Content-Type"), -1)
media.class <- mediaClassFromContentType(content.type)
content.params <-
content.params[intersect(names(content.params), slotNames(media.class))]
if (media.class == "NullMedia") {
new("NullMedia", cacheInfo = cacheInfoFromHeader(x$header))
} else {
do.call(new, c(media.class, x$body,
cacheInfo = cacheInfoFromHeader(x$header),
content.params))
}
}
mediaClassFromContentType <- function(x) {
if (is.null(x))
"NullMedia"
else if (is.character(x)) {
if (isClass(x))
x
else sub("/.*", "/*", x)
} else stop("content type should be character or NULL")
}
headerFromCacheInfo <- function(x) {
if (is.null(x))
NULL
else c("If-None-Match" = x@hash,
"If-Modified-Since" = formatHTTPDate(x@lastModified))
}
cacheInfoFromHeader <- function(x, original = CacheInfo()) {
x <- as.list(x)
cache.control <- parseCacheControl(x[["Cache-Control"]])
if (isTRUE(cache.control[["no-cache"]]))
expires <- Sys.time()
else if (!is.null(cache.control[["max-age"]]))
expires <- Sys.time() + cache.control[["max-age"]]
else expires <- parseHTTPDate(x[["Expires"]])
info.args <- list(expires = expires,
lastModified = parseHTTPDate(x[["Last-Modified"]]),
hash = x[["ETag"]])
info.args <- Filter(Negate(is.null), info.args)
do.call(initialize, c(original, info.args))
}
parseCacheControl <- function(x) {
if (is.null(x))
return(NULL)
fields <- strsplit(x, ", ")[[1]]
key.val <- strsplit(fields, "=")
keys <- sapply(key.val, head, 1)
has.val <- sapply(key.val, length) > 1L
l <- list()
l[keys[!has.val]] <- TRUE
l[keys[has.val]] <- sapply(key.val[has.val], tail, 1)
if (!is.null(l[["max-age"]]))
l[["max-age"]] <- as.integer(l[["max-age"]])
l
}
.httpParseDateString <- "%a, %d %b %Y %H:%M:%S"
.httpFormatDateString <- paste(.httpParseDateString, "%Z")
formatHTTPDate <- function(x) {
format(x, .httpFormatDateString, tz = "GMT")
}
parseHTTPDate <- function(x) {
if (is.null(x))
NULL
else strptime(x, .httpParseDateString, tz = "GMT")
}
authorization <- function(x) {
credentials <- credentials(x)
if (!is.null(credentials)) {
auth <- paste0(username(credentials), ":", password(credentials))
paste("Basic", base64(auth))
}
}
accept <- function(x) {
paste(x$accept, collapse=", ")
}
stopIfHTTPError <- function(header) {
stop.if.HTTP.error <- get("stop.if.HTTP.error", getNamespace("RCurl"))
stop.if.HTTP.error(header)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Status code constants
###
HTTP_STATUS <- setNames(as.list(as.integer(names(RCurl:::httpErrorClasses))),
RCurl:::httpErrorClasses)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.