response-status.r

#' 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)

  if (!status %in% names(http_statuses)) {
    stop("Unknown http status code: ", status, call. = FALSE)
  }

  status_desc <- http_statuses[[as.character(status)]]

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