Limit deep stack growth (#4156)

* Limit deep stack growth

* Improvements to deep stack trace culling

- Keep around the first deep stack trace; it may have useful
  information. (We may want to change this in the future to
  keep the first two stack traces, or even make it an option)
- Print out an indicator that we've elided stack traces, and
  how many

* Add comments

* Add NEWS item

* Add test for unlimited deep stacks

* Code review feedback

* Code review feedback

Co-authored-by: Carson Sievert <cpsievert1@gmail.com>

* Use head() over indexing

Co-authored-by: Carson Sievert <cpsievert1@gmail.com>

* Improve unit test robustness

* Remove vector indices from snapshot

* Make stack trace stripping work across deep stacks

* Pass tests

* Try passing tests again

* Rename keep_head to retain_first_n

* Remove misleading variable assignment

* Add more comments, refine dropTrivialTestFrames

* Don't call stripStackTraces if we're not stripping

* Use deep stack deduplication instead of elision

This hopefully will avoid any potential ..stacktraceon../off..
scoring issues, and will be more useful for users. The downside
is that it's still possible to have uselessly large deep stack
traces, but at least that will only happen now if you have
manually written gigantic async/promise chains by hand or maybe
did some clever metaprogramming. The coro case should be fine.

* Add coro-based unit test

* Use rlang::hash, it's much faster

* typo

Co-authored-by: Carson Sievert <cpsievert1@gmail.com>

* Remove unnecessary logic

* Simplify/robustify reactlog version checking test

* Warn only once on call stack digest cache miss

* Super conservatively wrap appendCallStackWithDupe in try/catch

* Use more specific attribute name

Co-authored-by: Carson Sievert <cpsievert1@gmail.com>

* Remove excessively cautious try/catch

---------

Co-authored-by: Carson Sievert <cpsievert1@gmail.com>

DESCRIPTION

@@ -95,6 +95,7 @@ Imports:
     cachem (>= 1.1.0),
     lifecycle (>= 0.2.0)
 Suggests:
+    coro (>= 1.1.0),
     datasets,
     DT,
     Cairo (>= 1.5-5),

NEWS.md

@@ -6,6 +6,8 @@
 
 * When spinners and the pulse busy indicators are enabled, Shiny now shows the pulse indicator when dynamic UI elements are recalculating if no other spinners are present in the app. (#4137)
 
+* Improve collection of deep stack traces (stack traces that are tracked across steps in an async promise chain) with `coro` async generators such as `elmer` chat streams. Previously, Shiny treated each iteration of an async generator as a distinct deep stack, leading to pathologically long stack traces; now, Shiny only keeps/prints unique deep stack trace, discarding duplicates. (#4156)
+
 ## Bug fixes
 
 * Fixed a bug in `conditionalPanel()` that would cause the panel to repeatedly show/hide itself when the provided condition was not boolean. (@kamilzyla, #4127)

R/conditions.R

@@ -130,6 +130,44 @@ captureStackTraces <- function(expr) {
 #' @include globals.R
 .globals$deepStack <- NULL
 
+getCallStackDigest <- function(callStack, warn = FALSE) {
+  dg <- attr(callStack, "shiny.stack.digest", exact = TRUE)
+  if (!is.null(dg)) {
+    return(dg)
+  }
+
+  if (isTRUE(warn)) {
+    rlang::warn(
+      "Call stack doesn't have a cached digest; expensively computing one now",
+      .frequency = "once",
+      .frequency_id = "deepstack-uncached-digest-warning"
+    )
+  }
+
+  rlang::hash(getCallNames(callStack))
+}
+
+saveCallStackDigest <- function(callStack) {
+  attr(callStack, "shiny.stack.digest") <- getCallStackDigest(callStack, warn = FALSE)
+  callStack
+}
+
+# Appends a call stack to a list of call stacks, but only if it's not already
+# in the list. The list is deduplicated by digest; ideally the digests on the
+# list are cached before calling this function (you will get a warning if not).
+appendCallStackWithDedupe <- function(lst, x) {
+  digests <- vapply(lst, getCallStackDigest, character(1), warn = TRUE)
+  xdigest <- getCallStackDigest(x, warn = TRUE)
+  stopifnot(all(nzchar(digests)))
+  stopifnot(length(xdigest) == 1)
+  stopifnot(nzchar(xdigest))
+  if (xdigest %in% digests) {
+    return(lst)
+  } else {
+    return(c(lst, list(x)))
+  }
+}
+
 createStackTracePromiseDomain <- function() {
   # These are actually stateless, we wouldn't have to create a new one each time
   # if we didn't want to. They're pretty cheap though.
@@ -142,13 +180,14 @@ createStackTracePromiseDomain <- function() {
         currentStack <- sys.calls()
         currentParents <- sys.parents()
         attr(currentStack, "parents") <- currentParents
+        currentStack <- saveCallStackDigest(currentStack)
         currentDeepStack <- .globals$deepStack
       }
       function(...) {
         # Fulfill time
         if (deepStacksEnabled()) {
           origDeepStack <- .globals$deepStack
-          .globals$deepStack <- c(currentDeepStack, list(currentStack))
+          .globals$deepStack <- appendCallStackWithDedupe(currentDeepStack, currentStack)
           on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
         }
 
@@ -165,13 +204,14 @@ createStackTracePromiseDomain <- function() {
         currentStack <- sys.calls()
         currentParents <- sys.parents()
         attr(currentStack, "parents") <- currentParents
+        currentStack <- saveCallStackDigest(currentStack)
         currentDeepStack <- .globals$deepStack
       }
       function(...) {
         # Fulfill time
         if (deepStacksEnabled()) {
           origDeepStack <- .globals$deepStack
-          .globals$deepStack <- c(currentDeepStack, list(currentStack))
+          .globals$deepStack <- appendCallStackWithDedupe(currentDeepStack, currentStack)
           on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
         }
 
@@ -199,6 +239,7 @@ doCaptureStack <- function(e) {
     calls <- sys.calls()
     parents <- sys.parents()
     attr(calls, "parents") <- parents
+    calls <- saveCallStackDigest(calls)
     attr(e, "stack.trace") <- calls
   }
   if (deepStacksEnabled()) {
@@ -281,88 +322,115 @@ printStackTrace <- function(cond,
   full = get_devmode_option("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
-  should_drop <- !full
+  stackTraces <- c(
-  should_strip <- !full
-  should_prune <- !full
-
-  stackTraceCalls <- c(
     attr(cond, "deep.stack.trace", exact = TRUE),
     list(attr(cond, "stack.trace", exact = TRUE))
   )
 
-  stackTraceParents <- lapply(stackTraceCalls, attr, which = "parents", exact = TRUE)
+  # Stripping of stack traces is the one step where the different stack traces
-  stackTraceCallNames <- lapply(stackTraceCalls, getCallNames)
+  # interact. So we need to do this in one go, instead of individually within
-  stackTraceCalls <- lapply(stackTraceCalls, offsetSrcrefs, offset = offset)
+  # printOneStackTrace.
-
+  if (!full) {
-  # Use dropTrivialFrames logic to remove trailing bits (.handleSimpleError, h)
+    stripResults <- stripStackTraces(lapply(stackTraces, getCallNames))
-  if (should_drop) {
+  } else {
-    # toKeep is a list of logical vectors, of which elements (stack frames) to keep
+    # If full is TRUE, we don't want to strip anything
-    toKeep <- lapply(stackTraceCallNames, dropTrivialFrames)
+    stripResults <- rep_len(list(TRUE), length(stackTraces))
-    # We apply the list of logical vector indices to each data structure
-    stackTraceCalls <- mapply(stackTraceCalls, FUN = `[`, toKeep, SIMPLIFY = FALSE)
-    stackTraceCallNames <- mapply(stackTraceCallNames, FUN = `[`, toKeep, SIMPLIFY = FALSE)
-    stackTraceParents <- mapply(stackTraceParents, FUN = `[`, toKeep, SIMPLIFY = FALSE)
   }
 
-  delayedAssign("all_true", {
+  mapply(
-    # List of logical vectors that are all TRUE, the same shape as
+    seq_along(stackTraces),
-    # stackTraceCallNames. Delay the evaluation so we don't create it unless
+    rev(stackTraces),
-    # we need it, but if we need it twice then we don't pay to create it twice.
+    rev(stripResults),
-    lapply(stackTraceCallNames, function(st) {
+    FUN = function(i, trace, stripResult) {
-      rep_len(TRUE, length(st))
+      if (is.integer(trace)) {
-    })
+        noun <- if (trace > 1L) "traces" else "trace"
-  })
+        message("[ reached getOption(\"shiny.deepstacktrace\") -- omitted ", trace, " more stack ", noun, " ]")
-
+      } else {
-  # stripStackTraces and lapply(stackTraceParents, pruneStackTrace) return lists
+        if (i != 1) {
-  # of logical vectors. Use mapply(FUN = `&`) to boolean-and each pair of the
+          message("From earlier call:")
-  # logical vectors.
+        }
-  toShow <- mapply(
+        printOneStackTrace(
-    if (should_strip) stripStackTraces(stackTraceCallNames) else all_true,
+          stackTrace = trace,
-    if (should_prune) lapply(stackTraceParents, pruneStackTrace) else all_true,
+          stripResult = stripResult,
-    FUN = `&`,
+          full = full,
+          offset = offset
+        )
+      }
+      # No mapply return value--we're just printing
+      NULL
+    },
     SIMPLIFY = FALSE
   )
 
-  dfs <- mapply(seq_along(stackTraceCalls), rev(stackTraceCalls), rev(stackTraceCallNames), rev(toShow), FUN = function(i, calls, nms, index) {
-    st <- data.frame(
-      num = rev(which(index)),
-      call = rev(nms[index]),
-      loc = rev(getLocs(calls[index])),
-      category = rev(getCallCategories(calls[index])),
-      stringsAsFactors = FALSE
-    )
-
-    if (i != 1) {
-      message("From earlier call:")
-    }
-
-    if (nrow(st) == 0) {
-      message("  [No stack trace available]")
-    } else {
-      width <- floor(log10(max(st$num))) + 1
-      formatted <- paste0(
-        "  ",
-        formatC(st$num, width = width),
-        ": ",
-        mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
-          if (category == "pkg")
-            crayon::silver(name)
-          else if (category == "user")
-            crayon::blue$bold(name)
-          else
-            crayon::white(name)
-        }),
-        "\n"
-      )
-      cat(file = stderr(), formatted, sep = "")
-    }
-
-    st
-  }, SIMPLIFY = FALSE)
-
   invisible()
 }
 
+printOneStackTrace <- function(stackTrace, stripResult, full, offset) {
+  calls <- offsetSrcrefs(stackTrace, offset = offset)
+  callNames <- getCallNames(stackTrace)
+  parents <- attr(stackTrace, "parents", exact = TRUE)
+
+  should_drop <- !full
+  should_strip <- !full
+  should_prune <- !full
+
+  if (should_drop) {
+    toKeep <- dropTrivialFrames(callNames)
+    calls <- calls[toKeep]
+    callNames <- callNames[toKeep]
+    parents <- parents[toKeep]
+    stripResult <- stripResult[toKeep]
+  }
+
+  toShow <- rep(TRUE, length(callNames))
+  if (should_prune) {
+    toShow <- toShow & pruneStackTrace(parents)
+  }
+  if (should_strip) {
+    toShow <- toShow & stripResult
+  }
+
+  # If we're running in testthat, hide the parts of the stack trace that can
+  # vary based on how testthat was launched. It's critical that this is not
+  # happen at the same time as dropTrivialFrames, which happens before
+  # pruneStackTrace; because dropTrivialTestFrames removes calls from the top
+  # (or bottom? whichever is the oldest?) of the stack, it breaks `parents`
+  # which is based on absolute indices of calls. dropTrivialFrames gets away
+  # with this because it only removes calls from the opposite side of the stack.
+  toShow <- toShow & dropTrivialTestFrames(callNames)
+
+  st <- data.frame(
+    num = rev(which(toShow)),
+    call = rev(callNames[toShow]),
+    loc = rev(getLocs(calls[toShow])),
+    category = rev(getCallCategories(calls[toShow])),
+    stringsAsFactors = FALSE
+  )
+
+  if (nrow(st) == 0) {
+    message("  [No stack trace available]")
+  } else {
+    width <- floor(log10(max(st$num))) + 1
+    formatted <- paste0(
+      "  ",
+      formatC(st$num, width = width),
+      ": ",
+      mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
+        if (category == "pkg")
+          crayon::silver(name)
+        else if (category == "user")
+          crayon::blue$bold(name)
+        else
+          crayon::white(name)
+      }),
+      "\n"
+    )
+    cat(file = stderr(), formatted, sep = "")
+  }
+
+  invisible(st)
+}
+
 stripStackTraces <- function(stackTraces, values = FALSE) {
   score <- 1L  # >=1: show, <=0: hide
   lapply(seq_along(stackTraces), function(i) {
@@ -458,6 +526,33 @@ dropTrivialFrames <- function(callnames) {
   )
 }
 
+dropTrivialTestFrames <- function(callnames) {
+  if (!identical(Sys.getenv("TESTTHAT_IS_SNAPSHOT"), "true")) {
+    return(rep_len(TRUE, length(callnames)))
+  }
+
+  hideable <- callnames %in% c(
+    "test",
+    "devtools::test",
+    "test_check",
+    "testthat::test_check",
+    "test_dir",
+    "testthat::test_dir",
+    "test_file",
+    "testthat::test_file",
+    "test_local",
+    "testthat::test_local"
+  )
+
+  firstGoodCall <- min(which(!hideable))
+  toRemove <- firstGoodCall - 1L
+
+  c(
+    rep_len(FALSE, toRemove),
+    rep_len(TRUE, length(callnames) - toRemove)
+  )
+}
+
 offsetSrcrefs <- function(calls, offset = TRUE) {
   if (offset) {
     srcrefs <- getSrcRefs(calls)

tests/testthat/_snaps/stacks-deep.md

@@ -0,0 +1,685 @@
+# deep stack capturing
+
+    Code
+      cat(sep = "\n", formatError(err))
+    Output
+      Error in onFinally: boom
+          : stop
+          : onFinally [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : self$then
+          : promise$finally
+          : finally
+          : onRejected [test-stacks-deep.R#XXX]
+          : callback
+          : <Anonymous>
+          : onRejected
+          : handleReject
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnRejected
+          : promiseDomain$onThen
+          : action
+          : promise
+          : self$then
+          : promise$catch
+          : catch
+          : %...!%
+          : onFulfilled [test-stacks-deep.R#XXX]
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+
+---
+
+    Code
+      cat(sep = "\n", formatError(err, full = TRUE))
+    Output
+      Error in onFinally: boom
+          : h
+          : .handleSimpleError
+          : stop
+          : onFinally [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : withCallingHandlers
+          : callback
+          : force
+          : reenter_promise_domain
+          : <Anonymous>
+          : onFulfilled
+          : withVisible
+          : private$doResolve
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : base::tryCatch
+          : tryCatch
+          : resolve
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : with_reporter
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : base::tryCatch
+          : tryCatch
+          : promise
+          : self$then
+          : promise$finally
+          : finally
+          : onRejected [test-stacks-deep.R#XXX]
+          : withCallingHandlers
+          : callback
+          : force
+          : reenter_promise_domain
+          : <Anonymous>
+          : onRejected
+          : withVisible
+          : private$doResolve
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : base::tryCatch
+          : tryCatch
+          : resolve
+          : handleReject
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : with_reporter
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnRejected
+          : promiseDomain$onThen
+          : action
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : base::tryCatch
+          : tryCatch
+          : promise
+          : self$then
+          : promise$catch
+          : catch
+          : %...!%
+          : onFulfilled [test-stacks-deep.R#XXX]
+          : withCallingHandlers
+          : callback
+          : force
+          : reenter_promise_domain
+          : <Anonymous>
+          : onFulfilled
+          : withVisible
+          : private$doResolve
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : base::tryCatch
+          : tryCatch
+          : resolve
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : with_reporter
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : base::tryCatch
+          : tryCatch
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : withCallingHandlers [test-stacks-deep.R#XXX]
+          : domain$wrapSync
+          : promises::with_promise_domain
+          : captureStackTraces
+          : as.promise
+          : catch
+          : %...!%
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : withCallingHandlers
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : doTryCatch
+          : tryCatchOne
+          : tryCatchList
+          : tryCatch
+          : with_reporter
+          : test_files_serial
+          : test_files
+
+# deep stacks long chain
+
+    Code
+      cat(sep = "\n", stacktrace <- formatError(dserr))
+    Output
+      Error in onFulfilled: boom
+          : stop
+          : onFulfilled [test-stacks-deep.R#XXX]
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : J__ [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : I__ [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : H__ [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : G__ [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : F__ [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : E__ [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : D__ [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : C__ [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : B__ [test-stacks-deep.R#XXX]
+          : onFulfilled
+          : callback
+          : <Anonymous>
+          : onFulfilled
+          : handleFulfill
+          : <Anonymous>
+          : execCallbacks
+          : later::run_now
+          : wait_for_it
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+      From earlier call:
+          : domain$wrapOnFulfilled
+          : promiseDomain$onThen
+          : action
+          : promise
+          : promise$then
+          : then
+          : %...>%
+          : A__ [test-stacks-deep.R#XXX]
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : test_that
+          : eval [test-stacks-deep.R#XXX]
+          : eval
+          : test_code
+          : source_file
+          : FUN
+          : lapply
+          : test_files_serial
+          : test_files
+

tests/testthat/test-reactlog.R

@@ -129,13 +129,9 @@ test_that("message logger appears", {
 
 
 test_that("reactlog_version is as expected", {
-  suggests <- strsplit(packageDescription("shiny")$Suggests, ",")[[1]]
+  expect_match(
-  reactlog <- trimws(
+    packageDescription("shiny")$Suggests,
-    grep("reactlog", suggests, value = TRUE)
+    # The space between reactlog and the version number can include \n
-  )
+    sprintf("\\breactlog\\s+\\Q(>= %s)\\E", reactlog_min_version)
-  expect_length(reactlog, 1)
-  expect_equal(
-    reactlog,
-    sprintf("reactlog (>= %s)", reactlog_min_version)
   )
 })

tests/testthat/test-stacks-deep.R

@@ -1,3 +1,47 @@
+formatError <- function(err, full = FALSE, offset = TRUE, cleanPaths = TRUE) {
+  # This complicated capturing code is necessary because printStackTrace uses a
+  # combination of `message()` and `cat(file=stderr())` to print the error,
+  # stack traces, and stack trace boundaries ("From earlier call:"). We want to
+  # treat all of it as part of the same string.
+
+  str <- noquote(capture.output(
+    suppressWarnings(
+      suppressMessages(
+        withCallingHandlers(
+          printError(err, full = full, offset = offset),
+          warning = function(cnd) {
+            cat(conditionMessage(cnd), "\n", sep = "", file = stderr())
+          },
+          message = function(cnd) {
+            cat(conditionMessage(cnd), file = stderr())
+          }
+        )
+      )
+    ),
+    type = "message"
+  ))
+
+  # Remove directories and line numbers from file/line references, e.g.
+  #   53: callback [/Users/jcheng/Development/rstudio/shiny/R/conditions.R#155]
+  # becomes
+  #   53: callback [conditions.R#XXX]
+  #
+  # This is to make the snapshot tests more stable across different machines and
+  # ignores benign code movement within a file.
+  str <- sub("#\\d+\\]$", "#XXX]", str, perl = TRUE)
+  # Remove any file/line number reference that's not test-stacks-deep.R. These
+  # are just too inconsistent across different ways of invoking testthat--not
+  # relative vs. absolute paths, but whether the file/line number is included at
+  # all!
+  str <- sub(" \\[(?!test-stacks-deep.R)[^[]+#XXX\\]", "", str, perl = TRUE)
+  # The frame numbers vary too much between different ways of invoking testthat
+  # ("Run Tests" editor toolbar button and "Test" Build tab button in RStudio,
+  # devtools::test(), etc.) so we blank them out.
+  str <- sub("^[ \\d]+:", "    :", str, perl = TRUE)
+  str
+}
+
+
 describe("deep stack trace filtering", {
   it("passes smoke test", {
     st <- list(
@@ -43,3 +87,170 @@ describe("deep stack trace filtering", {
     )
   })
 })
+
+test_that("deep stack capturing", {
+  `%...>%` <- promises::`%...>%`
+  `%...!%` <- promises::`%...!%`
+  finally <- promises::finally
+
+  err <- NULL
+  captureStackTraces({
+    promise_resolve("one") %...>% {
+      promise_reject("error") %...!% {
+        finally(promise_resolve("two"), ~{
+          stop("boom")
+        })
+      }
+    }
+  }) %...!% (function(err) {
+    err <<- err
+  })
+
+  wait_for_it()
+
+  expect_s3_class(err, "error", exact = FALSE)
+  expect_snapshot(cat(sep="\n", formatError(err)))
+  expect_snapshot(cat(sep="\n", formatError(err, full = TRUE)))
+})
+
+test_that("deep stack capturing within reactives", {
+  rerr <- NULL
+  observe({
+    promise_resolve("one") %...>% {
+      promise_resolve("two") %...>% {
+        stop("boom")
+      }
+    } %...!% (function(err) {
+      rerr <<- err
+    })
+  })
+
+  flushReact()
+  wait_for_it()
+
+  expect_s3_class(rerr, "error", exact = FALSE)
+  expect_length(attr(rerr, "deep.stack.trace"), 2)
+})
+
+test_that("deep stacks long chain", {
+  op <- options(shiny.deepstacktrace = 3L)
+  on.exit(options(op), add = TRUE, after = FALSE)
+
+  # Without deep stack traces, the stack trace would give no clue that the error
+  # originally started from a call to `A__()`. With deep stack traces, we can
+  # see that the error originated from `A__` and passed through `I__` and `J__`.
+  # But due to culling, we don't see `B__` through `H__`--these are omitted for
+  # brevity and to prevent unbounded growth of the accounting we do.
+
+  A__ <- function() promise_resolve(TRUE) %...>% B__()
+  B__ <- function(x) promise_resolve(TRUE) %...>% C__()
+  C__ <- function(x) promise_resolve(TRUE) %...>% D__()
+  D__ <- function(x) promise_resolve(TRUE) %...>% E__()
+  E__ <- function(x) promise_resolve(TRUE) %...>% F__()
+  F__ <- function(x) promise_resolve(TRUE) %...>% G__()
+  G__ <- function(x) promise_resolve(TRUE) %...>% H__()
+  H__ <- function(x) promise_resolve(TRUE) %...>% I__()
+  I__ <- function(x) promise_resolve(TRUE) %...>% J__()
+  J__ <- function(x) promise_resolve(TRUE) %...>% { stop("boom") }
+
+  dserr <- NULL
+  captureStackTraces(
+    A__()
+  ) %...!% (function(err) {
+    dserr <<- err
+  })
+
+  wait_for_it()
+
+  expect_s3_class(dserr, "error", exact = FALSE)
+  expect_snapshot(cat(sep="\n", stacktrace <- formatError(dserr)))
+  # Ensure we dropTrivialTestFrames only when snapshotting
+  expect_false(length(stacktrace) == length(formatError(dserr)))
+  # Ensure that A__ through J__ are present in the traces
+  for (letter in LETTERS[1:10]) {
+    expect_length(which(grepl(paste0(letter, "__"), stacktrace)), 1L)
+  }
+})
+
+test_that("Deep stack deduplication", {
+  recursive_promise <- function(n) {
+    if (n <= 0) {
+      stop("boom")
+    }
+
+    p <- promises::promise_resolve(TRUE)
+    promises::then(p, ~{
+      recursive_promise(n - 1)
+    })
+  }
+
+  op <- options(shiny.deepstacktrace = TRUE)
+  on.exit(options(op), add = TRUE, after = FALSE)
+
+  uerr <- NULL
+  captureStackTraces(recursive_promise(100)) %...!% (function(err) {
+    uerr <<- err
+  })
+
+  wait_for_it()
+
+  expect_s3_class(uerr, "error", exact = FALSE)
+  # Even though we traveled through 100 promises recursively, we only retained
+  # the unique ones
+  expect_identical(length(attr(uerr, "deep.stack.trace", exact = TRUE)), 2L)
+})
+
+test_that("stack trace stripping works", {
+  A__ <- function() promise_resolve(TRUE) %...>% B__()
+  B__ <- function(x) promise_resolve(TRUE) %...>% { ..stacktraceoff..(C__()) }
+  C__ <- function(x) promise_resolve(TRUE) %...>% D__()
+  D__ <- function(x) promise_resolve(TRUE) %...>% { ..stacktraceon..(E__()) }
+  E__ <- function(x) promise_resolve(TRUE) %...>% { stop("boom") }
+
+  strperr <- NULL
+  captureStackTraces(A__()) %...!% (function(err) {
+    strperr <<- err
+  })
+
+  ..stacktracefloor..(
+    wait_for_it()
+  )
+
+  expect_s3_class(strperr, "error", exact = FALSE)
+
+  str <- formatError(strperr)
+  expect_length(which(grepl("A__", str)), 1L)
+  expect_length(which(grepl("B__", str)), 1L)
+  expect_length(which(grepl("C__", str)), 0L)
+  expect_length(which(grepl("D__", str)), 0L)
+  expect_length(which(grepl("E__", str)), 1L)
+
+  str_full <- formatError(strperr, full = TRUE)
+  expect_length(which(grepl("A__", str_full)), 1L)
+  expect_length(which(grepl("B__", str_full)), 1L)
+  expect_length(which(grepl("C__", str_full)), 1L)
+  expect_length(which(grepl("D__", str_full)), 1L)
+  expect_length(which(grepl("E__", str_full)), 1L)
+})
+
+test_that("coro async generator deep stack count is low", {
+  gen <- coro::async_generator(function() {
+    for (i in 1:50) {
+      await(coro::async_sleep(0.001))
+      yield(i)
+    }
+    stop("boom")
+  })
+
+  cgerr <- NULL
+  captureStackTraces(
+    coro::async_collect(gen()) %...!% (function(err) {
+      cgerr <<- err
+    })
+  )
+
+  wait_for_it()
+
+  expect_s3_class(cgerr, "error", exact = FALSE)
+  expect_length(attr(cgerr, "deep.stack.trace"), 2L)
+})