diff --git a/DESCRIPTION b/DESCRIPTION index 9d0ea6787..11a6c31bf 100644 --- a/DESCRIPTION +++ b/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), diff --git a/NEWS.md b/NEWS.md index aebc2a506..359deea44 100644 --- a/NEWS.md +++ b/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) diff --git a/R/conditions.R b/R/conditions.R index 670a87432..164792a8d 100644 --- a/R/conditions.R +++ b/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,86 +322,113 @@ printStackTrace <- function(cond, full = get_devmode_option("shiny.fullstacktrace", FALSE), offset = getOption("shiny.stacktraceoffset", TRUE)) { - should_drop <- !full - should_strip <- !full - should_prune <- !full - - stackTraceCalls <- c( + stackTraces <- c( attr(cond, "deep.stack.trace", exact = TRUE), list(attr(cond, "stack.trace", exact = TRUE)) ) - stackTraceParents <- lapply(stackTraceCalls, attr, which = "parents", exact = TRUE) - stackTraceCallNames <- lapply(stackTraceCalls, getCallNames) - stackTraceCalls <- lapply(stackTraceCalls, offsetSrcrefs, offset = offset) - - # Use dropTrivialFrames logic to remove trailing bits (.handleSimpleError, h) - if (should_drop) { - # toKeep is a list of logical vectors, of which elements (stack frames) to keep - toKeep <- lapply(stackTraceCallNames, dropTrivialFrames) - # 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) + # Stripping of stack traces is the one step where the different stack traces + # interact. So we need to do this in one go, instead of individually within + # printOneStackTrace. + if (!full) { + stripResults <- stripStackTraces(lapply(stackTraces, getCallNames)) + } else { + # If full is TRUE, we don't want to strip anything + stripResults <- rep_len(list(TRUE), length(stackTraces)) } - delayedAssign("all_true", { - # List of logical vectors that are all TRUE, the same shape as - # stackTraceCallNames. Delay the evaluation so we don't create it unless - # we need it, but if we need it twice then we don't pay to create it twice. - lapply(stackTraceCallNames, function(st) { - rep_len(TRUE, length(st)) - }) - }) - - # stripStackTraces and lapply(stackTraceParents, pruneStackTrace) return lists - # of logical vectors. Use mapply(FUN = `&`) to boolean-and each pair of the - # logical vectors. - toShow <- mapply( - if (should_strip) stripStackTraces(stackTraceCallNames) else all_true, - if (should_prune) lapply(stackTraceParents, pruneStackTrace) else all_true, - FUN = `&`, + mapply( + seq_along(stackTraces), + rev(stackTraces), + rev(stripResults), + FUN = function(i, trace, stripResult) { + if (is.integer(trace)) { + noun <- if (trace > 1L) "traces" else "trace" + message("[ reached getOption(\"shiny.deepstacktrace\") -- omitted ", trace, " more stack ", noun, " ]") + } else { + if (i != 1) { + message("From earlier call:") + } + printOneStackTrace( + stackTrace = trace, + stripResult = stripResult, + 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 - ) + invisible() +} - if (i != 1) { - message("From earlier call:") - } +printOneStackTrace <- function(stackTrace, stripResult, full, offset) { + calls <- offsetSrcrefs(stackTrace, offset = offset) + callNames <- getCallNames(stackTrace) + parents <- attr(stackTrace, "parents", exact = TRUE) - 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 = "") - } + should_drop <- !full + should_strip <- !full + should_prune <- !full - st - }, SIMPLIFY = FALSE) + if (should_drop) { + toKeep <- dropTrivialFrames(callNames) + calls <- calls[toKeep] + callNames <- callNames[toKeep] + parents <- parents[toKeep] + stripResult <- stripResult[toKeep] + } - invisible() + 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) { @@ -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) diff --git a/tests/testthat/_snaps/stacks-deep.md b/tests/testthat/_snaps/stacks-deep.md new file mode 100644 index 000000000..0b7ca14c8 --- /dev/null +++ b/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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onRejected + : handleReject + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onFulfilled + : withVisible + : private$doResolve + : withCallingHandlers + : doTryCatch + : tryCatchOne + : tryCatchList + : base::tryCatch + : tryCatch + : resolve + : handleFulfill + : + : 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 + : + : onRejected + : withVisible + : private$doResolve + : withCallingHandlers + : doTryCatch + : tryCatchOne + : tryCatchList + : base::tryCatch + : tryCatch + : resolve + : handleReject + : + : 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 + : + : onFulfilled + : withVisible + : private$doResolve + : withCallingHandlers + : doTryCatch + : tryCatchOne + : tryCatchList + : base::tryCatch + : tryCatch + : resolve + : handleFulfill + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + : + : onFulfilled + : handleFulfill + : + : 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 + diff --git a/tests/testthat/test-reactlog.R b/tests/testthat/test-reactlog.R index 6c26cc9f6..3a9799af5 100644 --- a/tests/testthat/test-reactlog.R +++ b/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]] - reactlog <- trimws( - grep("reactlog", suggests, value = TRUE) - ) - expect_length(reactlog, 1) - expect_equal( - reactlog, - sprintf("reactlog (>= %s)", reactlog_min_version) + expect_match( + packageDescription("shiny")$Suggests, + # The space between reactlog and the version number can include \n + sprintf("\\breactlog\\s+\\Q(>= %s)\\E", reactlog_min_version) ) }) diff --git a/tests/testthat/test-stacks-deep.R b/tests/testthat/test-stacks-deep.R index b4262b1ed..eb335ad1e 100644 --- a/tests/testthat/test-stacks-deep.R +++ b/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) +})