Merge pull request rstudio#1156 from rstudio/barbara/error-hiding

Barbara/error hiding

Author: bborgesr

NAMESPACE

@@ -171,6 +171,7 @@ export(runGadget)
 export(runGist)
 export(runGitHub)
 export(runUrl)
+export(safeError)
 export(selectInput)
 export(selectizeInput)
 export(serverInfo)

R/conditions.R

@@ -131,9 +131,10 @@ withLogErrors <- function(expr,
     captureStackTraces(expr),
     error = function(cond) {
       # Don't print shiny.silent.error (i.e. validation errors)
-      if (inherits(cond, "shiny.silent.error"))
-        return()
-      printError(cond, full = full, offset = offset)
+      if (inherits(cond, "shiny.silent.error")) return()
+      if (isTRUE(getOption("show.error.messages"))) {
+        printError(cond, full = full, offset = offset)
+      }
     }
   )
 }

R/middleware.R

@@ -299,9 +299,7 @@ HandlerManager <- R6Class("HandlerManager",
 
           if (reqSize > maxSize) {
             return(list(status = 413L,
-              headers = list(
-                'Content-Type' = 'text/plain'
-              ),
+              headers = list('Content-Type' = 'text/plain'),
               body = 'Maximum upload size exceeded'))
           }
           else {
@@ -310,7 +308,18 @@ HandlerManager <- R6Class("HandlerManager",
         },
         call = .httpServer(
           function (req) {
-            withLogErrors(handlers$invoke(req))
+            withCallingHandlers(withLogErrors(handlers$invoke(req)),
+              error = function(cond) {
+                sanitizeErrors <- getOption('shiny.sanitize.errors', FALSE)
+                if (inherits(cond, 'shiny.custom.error') || !sanitizeErrors) {
+                  stop(cond$message, call. = FALSE)
+                } else {
+                  stop(paste("An error has occurred. Check your logs or",
+                             "contact the app author for clarification."),
+                       call. = FALSE)
+                }
+              }
+            )
           },
           getOption('shiny.sharedSecret')
         ),
@@ -333,7 +342,7 @@ HandlerManager <- R6Class("HandlerManager",
         }
 
         # Catch HEAD requests. For the purposes of handler functions, they
-        # should be treated like GET. The difference is that  they shouldn't
+        # should be treated like GET. The difference is that they shouldn't
         # return a body in the http response.
         head_request <- FALSE
         if (identical(req$REQUEST_METHOD, "HEAD")) {

R/shiny.R

@@ -96,6 +96,12 @@ NULL
 #'     an arguably more intuitive arrangement for casual R users, as the name
 #'     of a function appears next to the srcref where it is defined, rather than
 #'     where it is currently being called from.}
+#'   \item{shiny.sanitize.errors}{If \code{TRUE} (the default), then normal
+#'     errors (i.e. errors not wrapped in \code{safeError}) won't show up in the app;
+#'     a simple generic error message is printed instead (the error and strack trace
+#'     printed to the console remain unchanged). If you want this behavior in
+#'     general, but you DO want a particular error \code{e} to get displayed to the
+#'     user, please use \code{stop(safeError(e))} instead.}
 #' }
 #' @name shiny-options
 NULL
@@ -593,6 +599,10 @@ ShinySession <- R6Class(
 
           value <- tryCatch(
             shinyCallingHandlers(func()),
+            shiny.custom.error = function(cond) {
+              if (isTRUE(getOption("show.error.messages"))) printError(cond)
+              structure(NULL, class = "try-error", condition = cond)
+            },
             shiny.output.cancel = function(cond) {
               structure(NULL, class = "cancel-output")
             },
@@ -601,18 +611,16 @@ ShinySession <- R6Class(
               # path of try, because we don't want it to print. But we
               # do want to try to return the same looking result so that
               # the code below can send the error to the browser.
-              structure(
-                NULL,
-                class = "try-error",
-                condition = cond
-              )
+              structure(NULL, class = "try-error", condition = cond)
             },
             error = function(cond) {
-              msg <- paste0("Error in output$", name, ": ", conditionMessage(cond), "\n")
-              if (isTRUE(getOption("show.error.messages"))) {
-                printError(cond)
+              if (isTRUE(getOption("show.error.messages"))) printError(cond)
+              if (getOption("shiny.sanitize.errors", FALSE)) {
+                cond <- simpleError(paste("An error has occurred. Check your",
+                                          "logs or contact the app author for",
+                                          "clarification."))
               }
-              invisible(structure(msg, class = "try-error", condition = cond))
+              invisible(structure(NULL, class = "try-error", condition = cond))
             },
             finally = {
               private$sendMessage(recalculating = list(
@@ -898,13 +906,10 @@ ShinySession <- R6Class(
         # ..stacktraceon matches with the top-level ..stacktraceoff..
         result <- try(shinyCallingHandlers(Context$new(getDefaultReactiveDomain(), '[download]')$run(
           function() { ..stacktraceon..(download$func(tmpdata)) }
-        )))
+        )), silent = TRUE)
         if (inherits(result, 'try-error')) {
-          cond <- attr(result, 'condition', exact = TRUE)
-          printError(cond)
           unlink(tmpdata)
-          return(httpResponse(500, 'text/plain; charset=UTF-8',
-                              enc2utf8(conditionMessage(cond))))
+          stop(attr(result, "condition", exact = TRUE))
         }
         return(httpResponse(
           200,

R/utils.R

@@ -553,7 +553,13 @@ shinyCallingHandlers <- function(expr) {
         return()
 
       handle <- getOption('shiny.error')
-      if (is.function(handle)) handle()
+      if (is.function(handle)) {
+        if ("condition" %in% names(formals(handle))) {
+          handle(condition = e)
+        } else {
+          handle()
+        }
+      }
     }
   )
 }
@@ -886,6 +892,87 @@ columnToRowData <- function(data) {
   )
 }
 
+#' Declare an error safe for the user to see
+#'
+#' This should be used when you want to let the user see an error
+#' message even if the default is to sanitize all errors. If you have an
+#' error \code{e} and call \code{stop(safeError(e))}, then Shiny will
+#' ignore the value of \code{getOption("shiny.sanitize.errors")} and always
+#' display the error in the app itself.
+#'
+#' @param error Either an "error" object or a "character" object (string).
+#' In the latter case, the string will become the message of the error
+#' returned by \code{safeError}.
+#'
+#' @return An "error" object
+#'
+#' @details An error generated by \code{safeError} has priority over all
+#' other Shiny errors. This can be dangerous. For example, if you have set
+#' \code{options(shiny.sanitize.errors = TRUE)}, then by default all error
+#' messages are omitted in the app, and replaced by a generic error message.
+#' However, this does not apply to \code{safeError}: whatever you pass
+#' through \code{error} will be displayed to the user. So, this should only
+#' be used when you are sure that your error message does not contain any
+#' sensitive information. In those situations, \code{safeError} can make
+#' your users' lives much easier by giving them a hint as to where the
+#' error occurred.
+#'
+#' @seealso \code{\link{shiny-options}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' # uncomment the desired line to experiment with shiny.sanitize.errors
+#' # options(shiny.sanitize.errors = TRUE)
+#' # options(shiny.sanitize.errors = FALSE)
+#'
+#' # Define UI
+#' ui <- fluidPage(
+#'   textInput('number', 'Enter your favorite number from 1 to 10', '5'),
+#'   textOutput('normalError'),
+#'   textOutput('safeError')
+#' )
+#'
+#' # Server logic
+#' server <- function(input, output) {
+#'   output$normalError <- renderText({
+#'     number <- input$number
+#'     if (number %in% 1:10) {
+#'       return(paste('You chose', number, '!'))
+#'     } else {
+#'       stop(
+#'         paste(number, 'is not a number between 1 and 10')
+#'       )
+#'     }
+#'   })
+#'   output$safeError <- renderText({
+#'     number <- input$number
+#'     if (number %in% 1:10) {
+#'       return(paste('You chose', number, '!'))
+#'     } else {
+#'       stop(safeError(
+#'         paste(number, 'is not a number between 1 and 10')
+#'       ))
+#'     }
+#'   })
+#' }
+#'
+#' # Complete app with UI and server components
+#' shinyApp(ui, server)
+#' }
+#' @export
+safeError <- function(error) {
+  if (inherits(error, "character")) {
+    error <- simpleError(error)
+  }
+  if (!inherits(error, "error")) {
+    stop("The class of the `error` parameter must be either 'error' or 'character'")
+  }
+  class(error) <- c("shiny.custom.error", class(error))
+  error
+}
+
 #' Validate input values and other conditions
 #'
 #' For an output rendering function (e.g. \code{\link{renderPlot}()}), you may
@@ -979,8 +1066,8 @@ validate <- function(..., errorClass = character(0)) {
   # There may be empty strings remaining; these are message-less failures that
   # started as FALSE
   results <- results[nzchar(results)]
-
-  stopWithCondition(c("validation", errorClass), paste(results, collapse="\n"))
+  stopWithCondition(c("validation", "shiny.silent.error", errorClass),
+                    paste(results, collapse="\n"))
 }
 
 #' @param expr An expression to test. The condition will pass if the expression
@@ -1087,7 +1174,7 @@ req <- function(..., cancelOutput = FALSE) {
       if (isTRUE(cancelOutput)) {
         cancelOutput()
       } else {
-        stopWithCondition("validation", "")
+        stopWithCondition(c("validation", "shiny.silent.error"), "")
       }
     }
   }, ...)
@@ -1111,7 +1198,7 @@ req <- function(..., cancelOutput = FALSE) {
 #'
 #' @export
 cancelOutput <- function() {
-  stopWithCondition("shiny.output.cancel", "")
+  stopWithCondition(c("shiny.output.cancel", "shiny.silent.error"), "")
 }
 
 # Execute a function against each element of ..., but only evaluate each element
@@ -1154,7 +1241,7 @@ isTruthy <- function(x) {
 stopWithCondition <- function(class, message) {
   cond <- structure(
     list(message = message),
-    class = c(class, 'shiny.silent.error', 'error', 'condition')
+    class = c(class, 'error', 'condition')
   )
   stop(cond)
 }