Permalink
a99126c Dec 4, 2018
4 contributors

Users who have contributed to this file

@hadley @peterdesmet @gaborcsardi @bbrewington
333 lines (310 sloc) 10.1 KB
#' Extract status code from response.
#'
#' @param x A response
#' @export
status_code <- function(x) UseMethod("status_code")
#' @export
status_code.response <- function(x) x$status_code
#' @export
status_code.numeric <- function(x) x
#' Give information on the status of a request.
#'
#' Extract the http status code and convert it into a human readable message.
#'
#' http servers send a status code with the response to each request. This code
#' gives information regarding the outcome of the execution of the request
#' on the server. Roughly speaking, codes in the 100s and 200s mean the request
#' was successfully executed; codes in the 300s mean the page was redirected;
#' codes in the 400s mean there was a mistake in the way the client sent the
#' request; codes in the 500s mean the server failed to fulfill
#' an apparently valid request. More details on the codes can be found at
#' `http://en.wikipedia.org/wiki/Http_error_codes`.
#'
#' @param x a request object or a number.
#' @return If the status code does not match a known status, an error.
#' Otherwise, a list with components
#' \item{category}{the broad category of the status}
#' \item{message}{the meaning of the status code}
#' @family response methods
#' @examples
#' http_status(100)
#' http_status(404)
#'
#' x <- GET("http://httpbin.org/status/200")
#' http_status(x)
#'
#' http_status(GET("http://httpbin.org/status/300"))
#' http_status(GET("http://httpbin.org/status/301"))
#' http_status(GET("http://httpbin.org/status/404"))
#'
#' # errors out on unknown status
#' \dontrun{
#' http_status(GET("http://httpbin.org/status/320"))
#' }
#' @export
http_status <- function(x) {
status <- status_code(x)
status_desc <- http_statuses[[as.character(status)]]
if (is.na(status_desc)) {
stop("Unknown http status code: ", status, call. = FALSE)
}
status_types <- c(
"Information", "Success", "Redirection", "Client error",
"Server error"
)
status_type <- status_types[[status %/% 100]]
# create the final information message
message <- paste(status_type, ": (", status, ") ", status_desc, sep = "")
list(
category = status_type,
reason = status_desc,
message = message
)
}
http_statuses <- c(
"100" = "Continue",
"101" = "Switching Protocols",
"102" = "Processing (WebDAV; RFC 2518)",
"200" = "OK",
"201" = "Created",
"202" = "Accepted",
"203" = "Non-Authoritative Information",
"204" = "No Content",
"205" = "Reset Content",
"206" = "Partial Content",
"207" = "Multi-Status (WebDAV; RFC 4918)",
"208" = "Already Reported (WebDAV; RFC 5842)",
"226" = "IM Used (RFC 3229)",
"300" = "Multiple Choices",
"301" = "Moved Permanently",
"302" = "Found",
"303" = "See Other",
"304" = "Not Modified",
"305" = "Use Proxy",
"306" = "Switch Proxy",
"307" = "Temporary Redirect",
"308" = "Permanent Redirect (experimental Internet-Draft)",
"400" = "Bad Request",
"401" = "Unauthorized",
"402" = "Payment Required",
"403" = "Forbidden",
"404" = "Not Found",
"405" = "Method Not Allowed",
"406" = "Not Acceptable",
"407" = "Proxy Authentication Required",
"408" = "Request Timeout",
"409" = "Conflict",
"410" = "Gone",
"411" = "Length Required",
"412" = "Precondition Failed",
"413" = "Request Entity Too Large",
"414" = "Request-URI Too Long",
"415" = "Unsupported Media Type",
"416" = "Requested Range Not Satisfiable",
"417" = "Expectation Failed",
"418" = "I'm a teapot (RFC 2324)",
"420" = "Enhance Your Calm (Twitter)",
"422" = "Unprocessable Entity (WebDAV; RFC 4918)",
"423" = "Locked (WebDAV; RFC 4918)",
"424" = "Failed Dependency (WebDAV; RFC 4918)",
"424" = "Method Failure (WebDAV)",
"425" = "Unordered Collection (Internet draft)",
"426" = "Upgrade Required (RFC 2817)",
"428" = "Precondition Required (RFC 6585)",
"429" = "Too Many Requests (RFC 6585)",
"431" = "Request Header Fields Too Large (RFC 6585)",
"444" = "No Response (Nginx)",
"449" = "Retry With (Microsoft)",
"450" = "Blocked by Windows Parental Controls (Microsoft)",
"451" = "Unavailable For Legal Reasons (Internet draft)",
"499" = "Client Closed Request (Nginx)",
"500" = "Internal Server Error",
"501" = "Not Implemented",
"502" = "Bad Gateway",
"503" = "Service Unavailable",
"504" = "Gateway Timeout",
"505" = "HTTP Version Not Supported",
"506" = "Variant Also Negotiates (RFC 2295)",
"507" = "Insufficient Storage (WebDAV; RFC 4918)",
"508" = "Loop Detected (WebDAV; RFC 5842)",
"509" = "Bandwidth Limit Exceeded (Apache bw/limited extension)",
"510" = "Not Extended (RFC 2774)",
"511" = "Network Authentication Required (RFC 6585)",
"598" = "Network read timeout error (Unknown)",
"599" = "Network connect timeout error (Unknown)"
)
#' Check for an http error.
#'
#' @param x Object to check. Default methods are provided for strings
#' (which perform an [HEAD()] request), responses, and
#' integer status codes.
#' @param ... Other arguments passed on to methods.
#' @return `TRUE` if the request fails (status code 400 or above),
#' otherwise `FALSE`.
#' @export
#' @family response methods
#' @examples
#' # You can pass a url:
#' http_error("http://www.google.com")
#' http_error("http://httpbin.org/status/404")
#'
#' # Or a request
#' r <- GET("http://httpbin.org/status/201")
#' http_error(r)
#'
#' # Or an (integer) status code
#' http_error(200L)
#' http_error(404L)
http_error <- function(x, ...) {
UseMethod("http_error")
}
#' @export
http_error.character <- function(x, ...) {
http_error(HEAD(x, ...))
}
#' @export
http_error.response <- function(x, ...) {
http_error(status_code(x))
}
#' @export
http_error.integer <- function(x, ...) {
x >= 400L
}
#' @export
#' @rdname http_error
#' @usage NULL
url_success <- function(x, ...) {
warning(
"`url_success(x)` is deprecated; please use `!http_error(x)` instead.",
call. = FALSE
)
!http_error(x, ...)
}
#' @export
#' @rdname http_error
#' @usage NULL
url_ok <- function(x, ...) {
warning(
"`url_ok(x)` is deprecated; ",
"please use `identical(status_code(x), 200L)` instead.",
call. = FALSE
)
identical(status_code(HEAD(x, ...)), 200L)
}
#' Take action on http error.
#'
#' Converts http errors to R errors or warnings - these should always
#' be used whenever you're creating requests inside a function, so
#' that the user knows why a request has failed.
#'
#' @return If request was successful, the response (invisibly). Otherwise,
#' raised a classed http error or warning, as generated by
#' [http_condition()]
#' @inheritParams http_condition
#' @seealso [http_status()] and
#' `http://en.wikipedia.org/wiki/Http_status_codes` for more information
#' on http status codes.
#' @family response methods
#' @examples
#' x <- GET("http://httpbin.org/status/200")
#' stop_for_status(x) # nothing happens
#' warn_for_status(x)
#' message_for_status(x)
#'
#' x <- GET("http://httpbin.org/status/300")
#' \dontrun{
#' stop_for_status(x)
#' }
#' warn_for_status(x)
#' message_for_status(x)
#'
#' x <- GET("http://httpbin.org/status/404")
#' \dontrun{
#' stop_for_status(x)
#' }
#' warn_for_status(x)
#' message_for_status(x)
#'
#' # You can provide more information with the task argument
#' warn_for_status(x, "download spreadsheet")
#' message_for_status(x, "download spreadsheet")
#' @export
stop_for_status <- function(x, task = NULL) {
if (status_code(x) < 300) {
return(invisible(x))
}
call <- sys.call(-1)
stop(http_condition(x, "error", task = task, call = call))
}
#' @rdname stop_for_status
#' @export
warn_for_status <- function(x, task = NULL) {
if (status_code(x) < 300) {
return(invisible(x))
}
call <- sys.call(-1)
warning(http_condition(x, "warning", task = task, call = call))
}
#' @rdname stop_for_status
#' @export
message_for_status <- function(x, task = NULL) {
call <- sys.call(-1)
message(http_condition(x, "message", task = task, call = call))
}
#' Generate a classed http condition.
#'
#' This function generate S3 condition objects which are passed to
#' [stop()] or [warning()] to generate classes warnings
#' and error. These can be used in conjunction with [tryCatch()]
#' to respond differently to different type of failure.
#'
#' @keywords internal
#' @return An S3 object that inherits from (e.g.) condition, `type`,
#' http_error, http_400 and http_404.
#' @param x a response, or numeric http code (or other object with
#' `status_code` method)
#' @param type type of condition to generate. Must be one of error,
#' warning or message.
#' @param task The text of the message: either `NULL` or a
#' character vector. If non-`NULL`, the error message will finish with
#' "Failed to `task`".
#' @param call The call stored in the condition object.
#' @seealso
#' <http://adv-r.had.co.nz/Exceptions-Debugging.html#condition-handling>
#' for more details about R's condition handling model
#' @export
#' @examples
#' # You can use tryCatch to take different actions based on the type
#' # of error. Note that tryCatch will call the first handler that
#' # matches any classes of the condition, not the best matching, so
#' # always list handlers from most specific to least specific
#' f <- function(url) {
#' tryCatch(stop_for_status(GET(url)),
#' http_404 = function(c) "That url doesn't exist",
#' http_403 = function(c) "You need to authenticate!",
#' http_400 = function(c) "You made a mistake!",
#' http_500 = function(c) "The server screwed up"
#' )
#' }
#' f("http://httpbin.org/status/404")
#' f("http://httpbin.org/status/403")
#' f("http://httpbin.org/status/505")
http_condition <- function(x, type, task = NULL, call = sys.call(-1)) {
type <- match.arg(type, c("error", "warning", "message"))
if (is.null(task)) {
task <- ""
} else if (is.character(task)) {
task <- paste0(" Failed to ", task, ".")
} else {
stop("`task` must be NULL or a character vector", call. = FALSE)
}
status <- status_code(x)
reason <- http_status(status)$reason
message <- sprintf("%s (HTTP %d).%s", reason, status, task)
status_type <- (status %/% 100) * 100
http_class <- paste0("http_", unique(c(status, status_type, "error")))
structure(
list(message = message, call = call),
class = c(http_class, type, "condition")
)
}