From 7f5d067601c1d160ed8ec0766923ebd4f5db2fef Mon Sep 17 00:00:00 2001
From: Bruno Tremblay <bruno@boostao.ca>
Date: Sat, 9 Dec 2023 19:55:34 -0500
Subject: [PATCH] First draft

---
 DESCRIPTION                             |   4 +-
 NAMESPACE                               |  30 ++++++
 R/default-handlers.R                    |   8 +-
 R/plumber-static.R                      |   3 +-
 R/plumber.R                             |   8 +-
 R/pr_set.R                              |   6 +-
 R/reexport-httpproblems.R               | 125 ++++++++++++++++++++++++
 R/shared-secret-filter.R                |  13 +--
 inst/plumber/01-append/plumber.R        |  10 +-
 inst/plumber/02-filters/plumber.R       |   6 +-
 inst/plumber/03-github/plumber.R        |   6 +-
 inst/plumber/11-car-inventory/plumber.R |  21 ++--
 man/pr_set_404.Rd                       |   3 +-
 man/pr_set_error.Rd                     |   3 +-
 man/reexports.Rd                        |  30 ++++++
 15 files changed, 228 insertions(+), 48 deletions(-)
 create mode 100644 R/reexport-httpproblems.R
 create mode 100644 man/reexports.Rd

diff --git a/DESCRIPTION b/DESCRIPTION
index 3d6625a66..957dbd65e 100644
--- a/DESCRIPTION
+++ b/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'
diff --git a/NAMESPACE b/NAMESPACE
index e0773c28e..a658e1b56 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -9,6 +9,8 @@ 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)
@@ -16,15 +18,20 @@ 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)
diff --git a/R/default-handlers.R b/R/default-handlers.R
index 3ea03b21f..d0c795fe5 100644
--- a/R/default-handlers.R
+++ b/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)
     }
 
diff --git a/R/plumber-static.R b/R/plumber-static.R
index 8d8073d5c..8d37ed674 100644
--- a/R/plumber-static.R
+++ b/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
       }
 
diff --git a/R/plumber.R b/R/plumber.R
index 9050b46a2..154a9b00b 100644
--- a/R/plumber.R
+++ b/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))
           }
         }
 
diff --git a/R/pr_set.R b/R/pr_set.R
index a62c81585..ef0eefaec 100644
--- a/R/pr_set.R
+++ b/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() %>%
diff --git a/R/reexport-httpproblems.R b/R/reexport-httpproblems.R
new file mode 100644
index 000000000..5ea824174
--- /dev/null
+++ b/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 = ""
+  )
+}
diff --git a/R/shared-secret-filter.R b/R/shared-secret-filter.R
index 9e3f72eed..520187589 100644
--- a/R/shared-secret-filter.R
+++ b/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)))
     }
   }
 
diff --git a/inst/plumber/01-append/plumber.R b/inst/plumber/01-append/plumber.R
index 2df08f11e..cf967b8cd 100644
--- a/inst/plumber/01-append/plumber.R
+++ b/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))
diff --git a/inst/plumber/02-filters/plumber.R b/inst/plumber/02-filters/plumber.R
index 29983954f..455c1e6d0 100644
--- a/inst/plumber/02-filters/plumber.R
+++ b/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()
diff --git a/inst/plumber/03-github/plumber.R b/inst/plumber/03-github/plumber.R
index 290e4eb55..bcb14ac03 100644
--- a/inst/plumber/03-github/plumber.R
+++ b/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...
diff --git a/inst/plumber/11-car-inventory/plumber.R b/inst/plumber/11-car-inventory/plumber.R
index 15e2d2924..9a4ec54f7 100644
--- a/inst/plumber/11-car-inventory/plumber.R
+++ b/inst/plumber/11-car-inventory/plumber.R
@@ -18,10 +18,10 @@ listCars <- function(){
 #* @get /car/<id:int>
 #* @response 404 No car with the given ID was found in the inventory.
 #* @tag cars
-getCar <- function(id, res){
+getCar <- function(id){
   car <- inventory[inventory$id == id,]
   if (nrow(car) == 0){
-    res$status <- 404
+    stop_for_not_found()
   }
   car
 }
@@ -49,13 +49,12 @@ validateCar <- function(make, model, year){
 #* @param price:numeric The price of the car in USD
 #* @response 400 Invalid user input provided
 #* @tag cars
-addCar <- function(make, model, edition, year, miles, price, res){
+addCar <- function(make, model, edition, year, miles, price){
   newId <- max(inventory$id) + 1
 
   valid <- validateCar(make, model, year)
   if (!is.null(valid)){
-    res$status <- 400
-    return(list(errors=paste0("Invalid car: ", valid)))
+    stop_for_bad_request(paste0("Invalid car: ", valid))
   }
 
   car <- list(
@@ -82,12 +81,11 @@ addCar <- function(make, model, edition, year, miles, price, res){
 #* @param price:numeric The price of the car in USD
 #* @put /car/<id:int>
 #* @tag cars
-updateCar <- function(id, make, model, edition, year, miles, price, res){
+updateCar <- function(id, make, model, edition, year, miles, price){
 
   valid <- validateCar(make, model, year)
   if (!is.null(valid)){
-    res$status <- 400
-    return(list(errors=paste0("Invalid car: ", valid)))
+    stop_for_bad_request(paste0("Invalid car: ", valid))
   }
 
   updated <- list(
@@ -101,7 +99,7 @@ updateCar <- function(id, make, model, edition, year, miles, price, res){
   )
 
   if (!(id %in% inventory$id)){
-    stop("No such ID: ", id)
+    stop_for_bad_request(paste0("No such ID: ", id))
   }
 
   inventory[inventory$id == id, ] <<- updated
@@ -112,10 +110,9 @@ updateCar <- function(id, make, model, edition, year, miles, price, res){
 #* @param id:int The ID of the car to delete
 #* @delete /car/<id:int>
 #* @tag cars
-deleteCar <- function(id, res){
+deleteCar <- function(id){
   if (!(id %in% inventory$id)){
-    res$status <- 400
-    return(list(errors=paste0("No such ID: ", id)))
+    stop_for_bad_request(paste0("No such ID: ", id))
   }
   inventory <<- inventory[inventory$id != id,]
 }
diff --git a/man/pr_set_404.Rd b/man/pr_set_404.Rd
index 1d16ae242..8cfa3b1f9 100644
--- a/man/pr_set_404.Rd
+++ b/man/pr_set_404.Rd
@@ -22,7 +22,8 @@ cannot be served by an existing endpoint or filter.
 \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() \%>\%
diff --git a/man/pr_set_error.Rd b/man/pr_set_error.Rd
index 9453165e8..6b1a64c4e 100644
--- a/man/pr_set_error.Rd
+++ b/man/pr_set_error.Rd
@@ -23,7 +23,8 @@ error
 \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() \%>\%
diff --git a/man/reexports.Rd b/man/reexports.Rd
new file mode 100644
index 000000000..be6fc099d
--- /dev/null
+++ b/man/reexports.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/reexport-httpproblems.R
+\docType{import}
+\name{reexports}
+\alias{reexports}
+\alias{http_problem_types}
+\alias{http_problem}
+\alias{bad_request}
+\alias{conflict}
+\alias{forbidden}
+\alias{not_found}
+\alias{unauthorized}
+\alias{internal_server_error}
+\alias{stop_for_http_problem}
+\alias{stop_for_bad_request}
+\alias{stop_for_conflict}
+\alias{stop_for_forbidden}
+\alias{stop_for_not_found}
+\alias{stop_for_unauthorized}
+\alias{stop_for_internal_server_error}
+\title{Objects exported from other packages}
+\keyword{internal}
+\description{
+These objects are imported from other packages. Follow the links
+below to see their documentation.
+
+\describe{
+  \item{httpproblems}{\code{\link[httpproblems:http_problem]{bad_request}}, \code{\link[httpproblems:http_problem]{conflict}}, \code{\link[httpproblems:http_problem]{forbidden}}, \code{\link[httpproblems]{http_problem}}, \code{\link[httpproblems]{http_problem_types}}, \code{\link[httpproblems:http_problem]{internal_server_error}}, \code{\link[httpproblems:http_problem]{not_found}}, \code{\link[httpproblems:stop_for_http_problem]{stop_for_bad_request}}, \code{\link[httpproblems:stop_for_http_problem]{stop_for_conflict}}, \code{\link[httpproblems:stop_for_http_problem]{stop_for_forbidden}}, \code{\link[httpproblems]{stop_for_http_problem}}, \code{\link[httpproblems:stop_for_http_problem]{stop_for_internal_server_error}}, \code{\link[httpproblems:stop_for_http_problem]{stop_for_not_found}}, \code{\link[httpproblems:stop_for_http_problem]{stop_for_unauthorized}}, \code{\link[httpproblems:http_problem]{unauthorized}}}
+}}
+