Use http problems error

DESCRIPTION

@@ -33,7 +33,8 @@ Imports:
  mime,
  lifecycle (>= 0.2.0),
  ellipsis (>= 0.3.0),
- rlang
+ rlang,
+ httpproblems
 ByteCompile: TRUE
 Suggests:
  testthat (>= 0.11.0),
@@ -85,6 +86,7 @@ Collate:
  'plumber-step.R'
  'pr.R'
  'pr_set.R'
+ 'reexport-httpproblems.R'
  'serializer.R'
  'session-cookie.R'
  'ui.R'

NAMESPACE

@@ -9,22 +9,29 @@ export(PlumberStatic)
 export(addSerializer)
 export(as_attachment)
 export(available_apis)
+export(bad_request)
+export(conflict)
 export(do_configure_https)
 export(do_deploy_api)
 export(do_forward)
 export(do_provision)
 export(do_remove_api)
 export(do_remove_forward)
 export(endpoint_serializer)
+export(forbidden)
 export(forward)
 export(getCharacterSet)
 export(get_character_set)
 export(get_option_or_env)
+export(http_problem)
+export(http_problem_types)
 export(include_file)
 export(include_html)
 export(include_md)
 export(include_rmd)
+export(internal_server_error)
 export(is_plumber)
+export(not_found)
 export(options_plumber)
 export(parser_csv)
 export(parser_feather)
@@ -100,12 +107,35 @@ export(serializer_write_file)
 export(serializer_yaml)
 export(sessionCookie)
 export(session_cookie)
+export(stop_for_bad_request)
+export(stop_for_conflict)
+export(stop_for_forbidden)
+export(stop_for_http_problem)
+export(stop_for_internal_server_error)
+export(stop_for_not_found)
+export(stop_for_unauthorized)
+export(unauthorized)
 export(validate_api_spec)
 import(R6)
 import(promises)
 import(stringi)
 importFrom(grDevices,dev.cur)
 importFrom(grDevices,dev.set)
+importFrom(httpproblems,bad_request)
+importFrom(httpproblems,conflict)
+importFrom(httpproblems,forbidden)
+importFrom(httpproblems,http_problem)
+importFrom(httpproblems,http_problem_types)
+importFrom(httpproblems,internal_server_error)
+importFrom(httpproblems,not_found)
+importFrom(httpproblems,stop_for_bad_request)
+importFrom(httpproblems,stop_for_conflict)
+importFrom(httpproblems,stop_for_forbidden)
+importFrom(httpproblems,stop_for_http_problem)
+importFrom(httpproblems,stop_for_internal_server_error)
+importFrom(httpproblems,stop_for_not_found)
+importFrom(httpproblems,stop_for_unauthorized)
+importFrom(httpproblems,unauthorized)
 importFrom(jsonlite,parse_json)
 importFrom(jsonlite,toJSON)
 importFrom(lifecycle,deprecated)

R/default-handlers.R

@@ -4,6 +4,9 @@ default404Handler <- function(req, res) {
  list(error="404 - Resource Not Found")
 }
 
+# This do not need to be a function that returns a function
+# since it does not take a debug arg anymore. Do something?
+# https://github.com/rstudio/plumber/commit/813f1b656784729eefeca2e7bb32c061e7af33d1
 defaultErrorHandler <- function(){
  function(req, res, err){
  print(err)
@@ -25,7 +28,10 @@ defaultErrorHandler <- function(){
 
 
  # Don't overly leak data unless they opt-in
- if (is.function(req$pr$getDebug) && isTRUE(req$pr$getDebug())) {
+ # Simplified condition since debug is not an arg anymore.
+ # Unless private$debug unlocked and replaced, can only be logical from isTRUE
+ # in setDebug (plumber.R)
+ if (req$pr$getDebug()) {
  li["message"] <- as.character(err)
  }
 

R/plumber-static.R

@@ -38,8 +38,9 @@ PlumberStatic <- R6Class(
  }
 
  badRequest <- function(res) {
- res$body <- "<h1>Bad Request</h1>"
+ res$setHeader("Content-Type" = "application/problem+json")
  res$status <- 400
+ res$body <- jsonlite::toJSON(bad_request(), auto_unbox = TRUE)
  res
  }
 

R/plumber.R

@@ -90,8 +90,8 @@ Plumber <- R6Class(
  self$setSerializer(serializer_json())
  # Default parsers to maintain legacy features
  self$setParsers(c("json", "form", "text", "octet", "multi"))
- self$setErrorHandler(defaultErrorHandler())
- self$set404Handler(default404Handler)
+ self$setErrorHandler(http_problem_response)
+ self$set404Handler(not_found_response)
  self$setDocs(TRUE)
  private$docs_info$has_not_been_set <- TRUE # set to know if `$setDocs()` has been called before `$run()`
  private$docs_callback <- rlang::missing_arg()
@@ -816,11 +816,9 @@ Plumber <- R6Class(
  if (isTRUE(get_option_or_env("plumber.methodNotAllowed", TRUE))) {
  # Notify about allowed verbs
  if (is_405(req$pr, req$PATH_INFO, req$REQUEST_METHOD)) {
- res$status <- 405L
  # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Allow
  res$setHeader("Allow", paste(req$verbsAllowed, collapse = ", "))
- res$serializer <- serializer_unboxed_json()
- return(list(error = "405 - Method Not Allowed"))
+ return(http_problem_response(req, res, 405L))
  }
  }
 

R/pr_set.R

@@ -49,7 +49,8 @@ pr_set_parsers <- function(pr, parsers) {
 #' \dontrun{
 #' handler_404 <- function(req, res) {
 #' res$status <- 404
-#' res$body <- "Oops"
+#' res$serializer <- serializer_unboxed_json(type = "application/problem+json")
+#' not_found("Oops")
 #' }
 #'
 #' pr() %>%
@@ -77,7 +78,8 @@ pr_set_404 <- function(pr, fun) {
 #' \dontrun{
 #' handler_error <- function(req, res, err){
 #' res$status <- 500
-#' list(error = "Custom Error Message")
+#' res$serializer <- serializer_unboxed_json(type = "application/problem+json")
+#' internal_server_error("Custom Error Message")
 #' }
 #'
 #' pr() %>%

R/reexport-httpproblems.R

@@ -0,0 +1,125 @@
+#' @importFrom httpproblems http_problem_types
+#' @export
+httpproblems::http_problem_types
+
+#' @importFrom httpproblems http_problem
+#' @export
+httpproblems::http_problem
+
+#' @importFrom httpproblems bad_request
+#' @export
+httpproblems::bad_request
+
+#' @importFrom httpproblems conflict
+#' @export
+httpproblems::conflict
+
+#' @importFrom httpproblems forbidden
+#' @export
+httpproblems::forbidden
+
+#' @importFrom httpproblems not_found
+#' @export
+httpproblems::not_found
+
+#' @importFrom httpproblems unauthorized
+#' @export
+httpproblems::unauthorized
+
+#' @importFrom httpproblems internal_server_error
+#' @export
+httpproblems::internal_server_error
+
+#' @importFrom httpproblems stop_for_http_problem
+#' @export
+httpproblems::stop_for_http_problem
+
+#' @importFrom httpproblems stop_for_bad_request
+#' @export
+httpproblems::stop_for_bad_request
+
+#' @importFrom httpproblems stop_for_conflict
+#' @export
+httpproblems::stop_for_conflict
+
+#' @importFrom httpproblems stop_for_forbidden
+#' @export
+httpproblems::stop_for_forbidden
+
+#' @importFrom httpproblems stop_for_not_found
+#' @export
+httpproblems::stop_for_not_found
+
+#' @importFrom httpproblems stop_for_unauthorized
+#' @export
+httpproblems::stop_for_unauthorized
+
+#' @importFrom httpproblems stop_for_internal_server_error
+#' @export
+httpproblems::stop_for_internal_server_error
+
+http_problem_response <- function(req, res, problem) {
+ # The default is a 200. If that's still set, then we should probably override with a 500.
+ if (res$status == 200L) {
+ res$status = 500L
+ }
+ res$serializer <- serializer_unboxed_json(type = "application/problem+json")
+ problem <- to_http_problem(req, res, problem)
+ log_problem(req, res, problem)
+ # Don't leak
+ # dropped is function and isTRUE, already done within setDebug
+ # getDebug binding is locked
+ if (!req$pr$getDebug()) problem$detail <- NULL
+ return(problem)
+}
+
+not_found_response <- function(req, res) {
+ http_problem_response(req, res, 404L)
+}
+
+to_http_problem <- function(req, res, problem) {
+ UseMethod("to_http_problem", problem)
+}
+
+to_http_problem.default <- function(req, res, problem) {
+ http_problem(status = res$status)
+}
+
+to_http_problem.character <- function(req, res, problem) {
+ http_problem(detail = problem, status = res$status)
+}
+
+to_http_problem.numeric <- function(req, res, problem) {
+ problem <- http_problem(status = problem)
+ # set status after in case problem is invalid
+ res$status <- problem$status
+ return(problem)
+}
+
+to_http_problem.http_problem <- function(req, res, problem) {
+ res$status <- problem$status
+ return(problem)
+}
+
+to_http_problem.http_problem_error <- function(req, res, problem) {
+ res$status <- problem$body$status
+ return(problem$body)
+}
+
+to_http_problem.condition <- function(req, res, problem) {
+ http_problem(detail = conditionMessage(problem), status = res$status)
+}
+
+
+
+log_problem <- function(req, res, problem) {
+ # Fixed log format, bring in customization?
+ cat(
+ req$REMOTE_ADDR, " - ", "[", format(Sys.time(), "%F %T %z"), "] ",
+ '"', req$REQUEST_METHOD, " ", req$PATH_INFO, '" ',
+ problem$title, " (HTTP ", res$status, ") (", length(req$bodyRaw), " bytes sent) (",
+ problem$detail ,") ",
+ '"', req$HTTP_REFERER, " ", req$HTTP_USER_AGENT, '"',
+ "\n", file = stderr(), sep = ""
+ )
+}

R/shared-secret-filter.R

@@ -4,17 +4,10 @@ sharedSecretFilter <- function(req, res){
  if (!is.null(secret)){
  supplied <- req$HTTP_PLUMBER_SHARED_SECRET
  if (!identical(supplied, secret)){
- res$status <- 400
- # Force the route to return as unboxed json
- res$serializer <- serializer_unboxed_json()
- # Using output similar to `defaultErrorHandler()`
- li <- list(error = "400 - Bad request")
-
  # Don't overly leak data unless they opt-in
- if (is.function(req$pr$getDebug) && isTRUE(req$pr$getDebug())) {
- li$message <- "Shared secret mismatch"
- }
- return(li)
+ msg <- if (req$pr$getDebug()) "Shared secret mismatch"
+
+ return(http_problem_response(req, res, bad_request(msg)))
  }
  }
 

inst/plumber/01-append/plumber.R

@@ -4,11 +4,10 @@ MAX_VALS <- 50
 
 #* Append to our values
 #* @post /append
-function(val, res){
+function(val){
  v <- as.numeric(val)
  if (is.na(v)){
- res$status <- 400
- res$body <- "val parameter must be a number"
+ stop_for_bad_request("val parameter must be a number")
  }
  values <<- c(values, val)
 
@@ -21,11 +20,10 @@ function(val, res){
 
 #* Get the last few values
 #* @get /tail
-function(n="10", res){
+function(n="10"){
  n <- as.numeric(n)
  if (is.na(n) || n < 1 || n > MAX_VALS){
- res$status <- 400
- res$body <- "parameter 'n' must be a number between 1 and 100"
+ stop_for_bad_request("parameter 'n' must be a number between 1 and 100")
  }
 
  list(val=tail(values, n=n))

inst/plumber/02-filters/plumber.R

@@ -37,12 +37,10 @@ function(req, username=""){
 
 #* Now require that all users must be authenticated.
 #* @filter require-auth
-function(req, res){
+function(req){
  if (is.null(req$user)){
  # User isn't logged in
-
- res$status <- 401 # Unauthorized
- list(error="You must login to access this resource.")
+ stop_for_unauthorized("You must login to access this resource.")
  } else {
  # user is logged in. Move on...
  forward()

inst/plumber/03-github/plumber.R

@@ -17,14 +17,12 @@ function(){
 #* Give GitHub Webhook a way to alert us about new pushes to the repo
 #* https://developer.github.com/webhooks/
 #* @post /update
-function(req, res){
+function(req){
  secret <- readLines("./github-key.txt")[1]
  hm <- digest::hmac(secret, req$body, algo="sha1")
  hm <- paste0("sha1=", hm)
  if (!identical(hm, req$HTTP_X_HUB_SIGNATURE)){
- res$status <- 400
- res$body <- "invalid GitHub signature."
- return(res)
+ stop_for_bad_request("invalid GitHub signature.")
  }
 
  # DO...