diff --git a/DESCRIPTION b/DESCRIPTION index f6c49ea14..59a5f70f0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -126,6 +126,7 @@ Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.3 Collate: + 'app-handle.R' 'globals.R' 'app-state.R' 'app_template.R' diff --git a/NEWS.md b/NEWS.md index 0348fa41d..75b268df4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,15 @@ # shiny (development version) +## New features + +* `runApp()`, `runExample()`, and `runGadget()` gain a `blocking` parameter. + When `blocking = FALSE`, the app runs in the background and returns a + `ShinyAppHandle` object immediately, without blocking the R session. The + handle provides `stop()`, `status()`, `url()`, and `result()` methods for + managing the app lifecycle. Multiple apps can run concurrently in + non-blocking mode. The default can be changed via + `options(shiny.blocking = FALSE)`. + ## Bug fixes and minor improvements * Fixed an issue with `actionLink()` that extended the link underline to whitespace around the text. (#4348) diff --git a/R/app-handle.R b/R/app-handle.R new file mode 100644 index 000000000..d79ad992f --- /dev/null +++ b/R/app-handle.R @@ -0,0 +1,86 @@ +# Handle returned by runApp() when blocking = FALSE +ShinyAppHandle <- R6::R6Class("ShinyAppHandle", + cloneable = FALSE, + + public = list( + initialize = function(appUrl, appState, cleanupFn, registerCapture) { + private$appUrl <- appUrl + private$appState <- appState + private$cleanupFn <- cleanupFn + + # Expose private captureResult to caller via callback registration + registerCapture(function() private$captureResult()) + + reg.finalizer(self, function(e) { + if (e$status() == "running") { + tryCatch(e$stop(), error = function(cnd) NULL, warning = function(cnd) NULL) + } + }, onexit = TRUE) + }, + + stop = function() { + if (self$status() != "running") { + warning("App is not running") + return(invisible(self)) + } + # Order matters: capture result from appState (reads retval/reterror), + # then mark the app as stopped, then run cleanup (which NULLs appState + # fields and removes the app from the registry). + private$captureResult() + private$appState$stopped <- TRUE + private$cleanupFn() + private$cleanupFn <- NULL + invisible(self) + }, + + url = function() private$appUrl, + + status = function() { + if (!private$stopped) { + "running" + } else if (!is.null(private$resultError)) { + "error" + } else { + "success" + } + }, + + result = function() { + if (self$status() == "running") { + stop("App is still running. Use status() to check if the app has stopped.") + } + if (!is.null(private$resultError)) { + stop(private$resultError) + } + private$resultValue + }, + + print = function(...) { + cat("Shiny app handle\n") + cat(" URL: ", private$appUrl, "\n", sep = "") + cat(" Status:", self$status(), "\n") + invisible(self) + } + ), + + private = list( + appUrl = NULL, + appState = NULL, + cleanupFn = NULL, + # Whether this handle has captured the result. Distinct from appState$stopped + # which tracks whether a stop was requested (set by stopApp() or stop()). + stopped = FALSE, + resultValue = NULL, + resultError = NULL, + + captureResult = function() { + if (private$stopped) return() + private$stopped <- TRUE + if (isTRUE(private$appState$reterror)) { + private$resultError <- private$appState$retval + } else if (!is.null(private$appState$retval)) { + private$resultValue <- private$appState$retval$value + } + } + ) +) diff --git a/R/app-state.R b/R/app-state.R index d5a64733d..5fe19cffd 100644 --- a/R/app-state.R +++ b/R/app-state.R @@ -4,23 +4,70 @@ NULL # The current app state is a place to read and hang state for the # currently-running application. This is useful for setting options that will # last as long as the application is running. +# +# Multiple apps can run concurrently (in non-blocking mode). Each app gets its +# own appState env, stored in .globals$appStates (keyed by token). The direct +# pointer .globals$currentAppState is set by the service loop before each +# iteration, so getCurrentAppState() is a single env read on the hot path. +# +# Fields on each appState env (set across several files): +# token - unique ID (initCurrentAppState) +# app - the shiny.appobj (initCurrentAppState) +# options - per-app shinyOptions snapshot (initCurrentAppState) +# onStopCallbacks - Callbacks registry (initCurrentAppState) +# onUnhandledErrorCallbacks - Callbacks registry (initCurrentAppState) +# handlerManager - HandlerManager (startApp, server.R) +# showcaseDefault - numeric showcase mode (setShowcaseDefault, showcase.R) +# showcaseOverride - logical showcase override (setShowcaseDefault, showcase.R) +# IncludeWWW - logical, include www/ in showcase (runApp) +# reterror - logical, TRUE if retval is an error (runApp) +# retval - return value or error from stopApp (runApp) +# stopped - logical, TRUE when stop requested (runApp / stopApp) +# .captureResult - callback to capture result (serviceAsync, server.R) +# .cleanup - cleanup closure (serviceAsync, server.R) -.globals$appState <- NULL +.globals$appStates <- list() +.globals$currentAppState <- NULL +.globals$serviceLoopRunning <- FALSE initCurrentAppState <- function(appobj) { - if (!is.null(.globals$appState)) { - stop("Can't initialize current app state when another is currently active.") - } - .globals$appState <- new.env(parent = emptyenv()) - .globals$appState$app <- appobj + appState <- new.env(parent = emptyenv()) + appState$token <- createUniqueId(8) + appState$app <- appobj # Copy over global options - .globals$appState$options <- .globals$options + appState$options <- .globals$options + # Per-app callback registries + appState$onStopCallbacks <- Callbacks$new() + appState$onUnhandledErrorCallbacks <- Callbacks$new() + # Fields set later by runApp / startApp / serviceAsync; listed here for + # discoverability. See field inventory above. + appState$handlerManager <- NULL + appState$showcaseDefault <- NULL + appState$showcaseOverride <- NULL + appState$IncludeWWW <- NULL + appState$reterror <- NULL + appState$retval <- NULL + appState$stopped <- NULL + appState$.captureResult <- NULL + appState$.cleanup <- NULL + .globals$appStates[[appState$token]] <- appState + .globals$currentAppState <- appState + appState } getCurrentAppState <- function() { - .globals$appState + .globals$currentAppState +} + +clearCurrentAppState <- function(token) { + .globals$appStates[[token]] <- NULL + # Clear pointer if it matches the token being removed + if (!is.null(.globals$currentAppState) && + identical(.globals$currentAppState$token, token)) { + .globals$currentAppState <- NULL + } } -clearCurrentAppState <- function() { - .globals$appState <- NULL +anyAppRunning <- function() { + length(.globals$appStates) > 0 } diff --git a/R/runapp.R b/R/runapp.R index f18951182..831b5f7cd 100644 --- a/R/runapp.R +++ b/R/runapp.R @@ -45,6 +45,21 @@ #' @param test.mode Should the application be launched in test mode? This is #' only used for recording or running automated tests. Defaults to the #' `shiny.testmode` option, or FALSE if the option is not set. +#' @param blocking If `TRUE` (the default), the function blocks and does not +#' return until the app is stopped. If `FALSE`, the app runs in the background +#' via `later` callbacks and the function returns immediately with a +#' `ShinyAppHandle` object that can be used to stop the app. The default can +#' be changed via `options(shiny.blocking = FALSE)`. Non-blocking mode +#' requires the `later` event loop to run; this happens automatically in +#' interactive sessions when idle at the console, but in scripts requires +#' calling [later::run_now()] repeatedly. +#' +#' @return If `blocking = TRUE`, returns the value passed to [stopApp()], or +#' throws an error if the app was stopped with an error. If `blocking = FALSE`, +#' returns a `ShinyAppHandle` object with methods `stop()`, `status()`, +#' `url()`, and `result()`. The `status()` method returns `"running"`, +#' `"success"`, or `"error"`. The `result()` method throws an error if called +#' while running, or re-throws the error if the app stopped with an error. #' #' @examples #' \dontrun{ @@ -91,7 +106,8 @@ runApp <- function( host=getOption('shiny.host', '127.0.0.1'), workerId="", quiet=FALSE, display.mode=c("auto", "normal", "showcase"), - test.mode=getOption('shiny.testmode', FALSE) + test.mode=getOption('shiny.testmode', FALSE), + blocking=getOption("shiny.blocking", TRUE) ) { # * Wrap **all** execution of the app inside the otel promise domain @@ -100,32 +116,54 @@ runApp <- function( # reactivated upon promise domain restoration promises::local_otel_promise_domain() - on.exit({ - handlerManager$clear() - }, add = TRUE) - - if (isRunning()) { - stop("Can't call `runApp()` from within `runApp()`. If your ", - "application code contains `runApp()`, please remove it.") + if (blocking && anyAppRunning()) { + stop("Can't call blocking runApp() while another app is running. ", + "Use blocking = FALSE to run multiple apps concurrently.") } # Make warnings print immediately # Set pool.scheduler to support pool package - ops <- options( - # Raise warn level to 1, but don't lower it - warn = max(1, getOption("warn", default = 1)), - pool.scheduler = scheduleTask - ) - on.exit(options(ops), add = TRUE) + # Only snapshot options on the first app to avoid later apps clobbering the + # snapshot or orphaning option values. + if (!anyAppRunning()) { + .globals$preAppOptions <- options( + # Raise warn level to 1, but don't lower it + warn = max(1, getOption("warn", default = 1)), + pool.scheduler = scheduleTask + ) + } # ============================================================================ # Global onStart/onStop callbacks # ============================================================================ - # Invoke user-defined onStop callbacks, before the application's internal - # onStop callbacks. + # Flag to control whether early cleanup runs on exit. + # For non-blocking mode, earlyCleanup is set to FALSE before returning. + # + # Cleanup paths: + # - Startup failure (earlyCleanup=TRUE): on.exit handlers fire for per-app + # callbacks, appParts$onStop, and global state. + # - Blocking exit (earlyCleanup=FALSE): on.exit calls cleanup(), which + # handles everything (server stop, callbacks, state removal). + # - Non-blocking return (earlyCleanup=FALSE): no on.exit cleanup; the + # shared service loop or handle$stop() calls cleanup() instead. + earlyCleanup <- TRUE + + # Pre-initialize to NULL so the on.exit handler can safely check it even if + # initCurrentAppState() hasn't run yet (e.g., failure in as.shiny.appobj()). + appState <- NULL + + # This on.exit handler ensures cleanup even if startup fails. on.exit({ - .globals$onStopCallbacks$invoke() - .globals$onStopCallbacks <- Callbacks$new() + if (earlyCleanup) { + if (!is.null(appState)) { + appState$onStopCallbacks$invoke() + if (!is.null(appState$handlerManager)) { + appState$handlerManager$clear() + } + clearCurrentAppState(appState$token) + } + cleanupGlobalState() + } }, add = TRUE) require(shiny) @@ -140,8 +178,7 @@ runApp <- function( # ============================================================================ # This is so calls to getCurrentAppState() can be used to find (A) whether an # app is running and (B), get options and data associated with the app. - initCurrentAppState(appParts) - on.exit(clearCurrentAppState(), add = TRUE) + appState <- initCurrentAppState(appParts) # Any shinyOptions set after this point will apply to the current app only # (and will not persist after the app stops). @@ -201,6 +238,8 @@ runApp <- function( display.mode <- findVal("display.mode", display.mode) if (missing(test.mode)) test.mode <- findVal("test.mode", test.mode) + if (missing(blocking)) + blocking <- findVal("blocking", blocking) if (is.null(host) || is.na(host)) host <- '0.0.0.0' @@ -265,13 +304,13 @@ runApp <- function( if (mode == "Showcase") { setShowcaseDefault(1) if ("IncludeWWW" %in% colnames(settings)) { - .globals$IncludeWWW <- as.logical(settings[1, "IncludeWWW"]) - if (is.na(.globals$IncludeWWW)) { + appState$IncludeWWW <- as.logical(settings[1, "IncludeWWW"]) + if (is.na(appState$IncludeWWW)) { stop("In your Description file, `IncludeWWW` ", "must be set to `True` (default) or `False`") } } else { - .globals$IncludeWWW <- TRUE + appState$IncludeWWW <- TRUE } } } @@ -280,8 +319,8 @@ runApp <- function( ## default is to show the .js, .css and .html files in the www directory ## (if not in showcase mode, this variable will simply be ignored) - if (is.null(.globals$IncludeWWW) || is.na(.globals$IncludeWWW)) { - .globals$IncludeWWW <- TRUE + if (is.null(appState$IncludeWWW) || is.na(appState$IncludeWWW)) { + appState$IncludeWWW <- TRUE } # If display mode is specified as an argument, apply it (overriding the @@ -340,25 +379,24 @@ runApp <- function( # onStart/onStop callbacks # ============================================================================ # Set up the onStop before we call onStart, so that it gets called even if an - # error happens in onStart. - if (!is.null(appParts$onStop)) - on.exit(appParts$onStop(), add = TRUE) + # error happens in onStart or later during startup. + if (!is.null(appParts$onStop)) { + on.exit({ + if (earlyCleanup) appParts$onStop() + }, add = TRUE) + } if (!is.null(appParts$onStart)) appParts$onStart() # ============================================================================ # Start/stop httpuv app # ============================================================================ - server <- startApp(appParts, port, host, quiet) + server <- startApp(appParts, port, host, quiet, appState) # Make the httpuv server object accessible. Needed for calling # addResourcePath while app is running. shinyOptions(server = server) - on.exit({ - stopServer(server) - }, add = TRUE) - # ============================================================================ # Launch web browser # ============================================================================ @@ -388,33 +426,109 @@ runApp <- function( # Application hooks # ============================================================================ callAppHook("onAppStart", appUrl) - on.exit({ - callAppHook("onAppStop", appUrl) - }, add = TRUE) + + # ============================================================================ + # Create cleanup function + # ============================================================================ + cleanup <- createCleanup(server, appParts, appUrl, appState) + + # Initialize per-app state for this app run (MUST happen before blocking check) + appState$reterror <- NULL + appState$retval <- NULL + appState$stopped <- FALSE # ============================================================================ # Run event loop via httpuv # ============================================================================ - .globals$reterror <- NULL - .globals$retval <- NULL - .globals$stopped <- FALSE - # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(), - # reactive(), Callbacks$invoke(), and others - ..stacktraceoff..( - captureStackTraces({ - while (!.globals$stopped) { - ..stacktracefloor..(serviceApp()) + # Startup complete - cleanup function now handles all cleanup + earlyCleanup <- FALSE + + if (blocking) { + # BLOCKING MODE: run while loop and cleanup on exit + on.exit(cleanup(), add = TRUE) + + # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(), + # reactive(), Callbacks$invoke(), and others + .globals$currentAppState <- appState + ..stacktraceoff..( + captureStackTraces({ + while (!appState$stopped) { + ..stacktracefloor..(serviceApp()) + } + }) + ) + + if (isTRUE(appState$reterror)) { + stop(appState$retval) + } + else if (appState$retval$visible) + appState$retval$value + else + invisible(appState$retval$value) + + } else { + # NON-BLOCKING MODE: return handle immediately, app runs via later callbacks + captureResult <- NULL + handle <- ShinyAppHandle$new( + appUrl = appUrl, + appState = appState, + cleanupFn = cleanup, + registerCapture = function(fn) captureResult <<- fn + ) + + tryCatch( + { + serviceAsync(appState, captureResult, cleanup) + handle + }, + error = function(e) { + cleanup() + stop(e) } - }) - ) + ) + } +} - if (isTRUE(.globals$reterror)) { - stop(.globals$retval) +# Invoke global onStop callbacks (registered before any app started) and +# restore process-level options when the last app stops. Called from both +# the early-cleanup on.exit handler and createCleanup(). Defers until no +# apps remain so that global callbacks fire once, not per-app. +cleanupGlobalState <- function() { + if (!anyAppRunning()) { + .globals$onStopCallbacks$invoke() + .globals$onStopCallbacks <- Callbacks$new() + if (!is.null(.globals$preAppOptions)) { + options(.globals$preAppOptions) + .globals$preAppOptions <- NULL + } + } +} + +# Consolidated cleanup function for runApp() +createCleanup <- function(server, appParts, appUrl, appState) { + cleanedUp <- FALSE + function() { + if (cleanedUp) return() + cleanedUp <<- TRUE + + appState$stopped <- TRUE + callAppHook("onAppStop", appUrl) + stopServer(server) + if (!is.null(appParts$onStop)) appParts$onStop() + appState$onStopCallbacks$invoke() + appState$handlerManager$clear() + clearCurrentAppState(appState$token) + cleanupGlobalState() + + # Release memory: the handle only needs stopped/retval/reterror post-cleanup + appState$app <- NULL + appState$options <- NULL + appState$onStopCallbacks <- NULL + appState$onUnhandledErrorCallbacks <- NULL + appState$handlerManager <- NULL + appState$.captureResult <- NULL + appState$.cleanup <- NULL } - else if (.globals$retval$visible) - .globals$retval$value - else - invisible(.globals$retval$value) } #' Stop the currently running Shiny app @@ -429,22 +543,27 @@ stopApp <- function(returnValue = invisible()) { # reterror will indicate whether retval is an error (i.e. it should be passed # to stop() when the serviceApp loop stops) or a regular value (in which case # it should simply be returned with the appropriate visibility). - .globals$reterror <- FALSE + appState <- getCurrentAppState() + if (is.null(appState)) { + # Silently ignore if no app is running (backward compat). + return(invisible()) + } + appState$reterror <- FALSE ..stacktraceoff..( tryCatch( { captureStackTraces( - .globals$retval <- withVisible(..stacktraceon..(force(returnValue))) + appState$retval <- withVisible(..stacktraceon..(force(returnValue))) ) }, error = function(e) { - .globals$retval <- e - .globals$reterror <- TRUE + appState$retval <- e + appState$reterror <- TRUE } ) ) - .globals$stopped <- TRUE + appState$stopped <- TRUE httpuv::interrupt() } @@ -495,7 +614,8 @@ runExample <- function( launch.browser = getOption("shiny.launch.browser", interactive()), host = getOption("shiny.host", "127.0.0.1"), display.mode = c("auto", "normal", "showcase"), - package = "shiny" + package = "shiny", + blocking = getOption("shiny.blocking", TRUE) ) { if (!identical(package, "shiny") && !is_installed(package)) { rlang::check_installed(package) @@ -528,7 +648,7 @@ runExample <- function( } runApp(dir, port = port, host = host, launch.browser = launch.browser, - display.mode = display.mode) + display.mode = display.mode, blocking = blocking) } #' Run a gadget @@ -548,7 +668,11 @@ runExample <- function( #' is automatically created that handles `input$cancel` by calling #' `stopApp()` with an error. Pass `FALSE` if you want to handle #' `input$cancel` yourself. -#' @return The value returned by the gadget. +#' @inheritParams runApp +#' @return If `blocking = TRUE` (the default), returns the value passed to +#' [stopApp()] by the gadget. If `blocking = FALSE`, returns a +#' `ShinyAppHandle` object; use `handle$result()` to retrieve the gadget's +#' return value after it stops. #' #' @examples #' \dontrun{ @@ -568,7 +692,8 @@ runExample <- function( #' } #' @export runGadget <- function(app, server = NULL, port = getOption("shiny.port"), - viewer = paneViewer(), stopOnCancel = TRUE) { + viewer = paneViewer(), stopOnCancel = TRUE, + blocking = getOption("shiny.blocking", TRUE)) { if (!is.shiny.appobj(app)) { app <- shinyApp(app, server) @@ -586,7 +711,7 @@ runGadget <- function(app, server = NULL, port = getOption("shiny.port"), viewer <- utils::browseURL } - shiny::runApp(app, port = port, launch.browser = viewer) + shiny::runApp(app, port = port, launch.browser = viewer, blocking = blocking) } # Add custom functionality to a Shiny app object's server func diff --git a/R/server.R b/R/server.R index 45f5f0958..202f34be7 100644 --- a/R/server.R +++ b/R/server.R @@ -132,7 +132,7 @@ on_load({ autoReloadCallbacks <- Callbacks$new() }) -createAppHandlers <- function(httpHandlers, serverFuncSource) { +createAppHandlers <- function(httpHandlers, serverFuncSource, appState = NULL) { appvars <- new.env() appvars$server <- NULL @@ -143,8 +143,23 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) { # denied (403 response for HTTP, and instant close for websocket). checkSharedSecret <- loadSharedSecret() + # Capture showcase settings from appState at creation time so they are + # available via closure even when httpuv dispatches handlers for another app. + showcaseDefault <- if (!is.null(appState)) appState$showcaseDefault else .globals$showcaseDefault + showcaseOverride <- if (!is.null(appState)) appState$showcaseOverride else .globals$showcaseOverride + + # Defense-in-depth: set the app pointer at the start of each HTTP request + # so that handlers like uiHttpHandler() can read from getCurrentAppState(). + httpContextHandler <- if (!is.null(appState)) { + function(req) { + .globals$currentAppState <- appState + NULL + } + } + appHandlers <- list( http = joinHandlers(c( + httpContextHandler, sessionHandler, httpHandlers, sys.www.root, @@ -152,6 +167,12 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) { reactLogHandler )), ws = function(ws) { + # Defense-in-depth: set the app pointer so any code that calls + # getCurrentAppState() during handler execution gets the correct app. + if (!is.null(appState)) { + .globals$currentAppState <- appState + } + if (!checkSharedSecret(ws$request$HTTP_SHINY_SHARED_SECRET)) { ws$close() return(TRUE) @@ -181,9 +202,9 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) { stopApp() } - shinysession <- ShinySession$new(ws) + shinysession <- ShinySession$new(ws, appState) appsByToken$set(shinysession$token, shinysession) - shinysession$setShowcase(.globals$showcaseDefault) + shinysession$setShowcase(showcaseDefault) messageHandler <- function(binary, msg) { withReactiveDomain(shinysession, { @@ -242,7 +263,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) { } # Check for switching into/out of showcase mode - if (.globals$showcaseOverride && + if (showcaseOverride && exists(".clientdata_url_search", where = msg$data)) { mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search) if (!is.null(mode)) @@ -354,11 +375,15 @@ identicalFunctionBodies <- function(a, b) { identical(getEffectiveBody(a), getEffectiveBody(b)) } -handlerManager <- HandlerManager$new() - addSubApp <- function(appObj, autoRemove = TRUE) { path <- createUniqueId(16, "/app") - appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource) + + # Sub-apps are added during session activity (inside serviceApp()), so + # getCurrentAppState() is correct. Capture the parent app's state so sub-app + # sessions get closure-based correctness (same guarantee as main app sessions). + appState <- getCurrentAppState() + appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource, appState) + handlerManager <- appState$handlerManager # remove the leading / from the path so a relative path is returned # (needed for the case where the root URL for the Shiny app isn't /, such @@ -373,22 +398,33 @@ addSubApp <- function(appObj, autoRemove = TRUE) { if (autoRemove) { # If a session is currently active, remove this subapp automatically when - # the current session ends + # the current session ends. Capture the handler manager reference so it + # removes from the correct one even if the callback fires during another + # app's service iteration. onReactiveDomainEnded(getDefaultReactiveDomain(), function() { - removeSubApp(finalPath) + removeSubApp(finalPath, handlerManager) }) } return(finalPath) } -removeSubApp <- function(path) { +removeSubApp <- function(path, handlerManager = NULL) { + if (is.null(handlerManager)) { + appState <- getCurrentAppState() + if (is.null(appState)) return(invisible()) + handlerManager <- appState$handlerManager + } handlerManager$removeHandler(path) handlerManager$removeWSHandler(path) } -startApp <- function(appObj, port, host, quiet) { - appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource) +startApp <- function(appObj, port, host, quiet, appState) { + # Each app gets its own handler manager + appState$handlerManager <- HandlerManager$new() + handlerManager <- appState$handlerManager + + appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource, appState) handlerManager$addHandler(appHandlers$http, "/", tail = TRUE) handlerManager$addWSHandler(appHandlers$ws, "/", tail = TRUE) @@ -498,6 +534,60 @@ serviceApp <- function() { flushPendingSessions() } +# Shared non-blocking service loop. A single later-based loop services all +# concurrent non-blocking apps, calling the process-global serviceApp() once +# per cycle rather than once per app. Each app registers its captureResult and +# cleanup callbacks on its appState; the loop handles per-app lifecycle. +serviceAsync <- function(appState, captureResult, cleanup) { + appState$.captureResult <- captureResult + appState$.cleanup <- cleanup + + if (!.globals$serviceLoopRunning) { + .globals$serviceLoopRunning <- TRUE + later::later(serviceLoop, delay = 0.001) + } +} + +serviceLoop <- function() { + ..stacktraceoff..( + captureStackTraces( + tryCatch( + ..stacktracefloor..(serviceApp()), + error = function(e) { + # Best-effort: attribute to whichever app the pointer refers to. + # Defense-in-depth handlers set the pointer during httpuv dispatch, + # so this is typically the app whose handler threw. + appState <- getCurrentAppState() + if (!is.null(appState) && !isTRUE(appState$stopped)) { + appState$stopped <- TRUE + appState$retval <- e + appState$reterror <- TRUE + } + } + ) + ) + ) + + # Handle stopped apps. Snapshot tokens since cleanup modifies the registry. + tokens <- names(.globals$appStates) + for (token in tokens) { + appState <- .globals$appStates[[token]] + if (!is.null(appState) && isTRUE(appState$stopped) && + !is.null(appState$.captureResult)) { + appState$.captureResult() + appState$.cleanup() + appState$.captureResult <- NULL + appState$.cleanup <- NULL + } + } + + if (anyAppRunning()) { + later::later(serviceLoop, delay = 0.001) + } else { + .globals$serviceLoopRunning <- FALSE + } +} + .shinyServerMinVersion <- '0.3.4' #' Check whether a Shiny application is running @@ -508,7 +598,7 @@ serviceApp <- function() { #' `FALSE`. #' @export isRunning <- function() { - !is.null(getCurrentAppState()) + anyAppRunning() } diff --git a/R/shiny.R b/R/shiny.R index d8cc2330c..7825c928d 100644 --- a/R/shiny.R +++ b/R/shiny.R @@ -345,6 +345,7 @@ ShinySession <- R6Class( private = list( # There are some private items with a leading "."; except for the dot, these # items share a name with a public item. + appState = NULL, # Reference to the owning app's state websocket = 'ANY', invalidatedOutputValues = 'Map', invalidatedOutputErrors = 'Map', @@ -710,8 +711,9 @@ ShinySession <- R6Class( groups = NULL, options = NULL, # For session-specific shinyOptions() - initialize = function(websocket) { + initialize = function(websocket, appState = NULL) { private$websocket <- websocket + private$appState <- appState self$closed <- FALSE # TODO: Put file upload context in user/app-specific dir if possible @@ -742,8 +744,13 @@ ShinySession <- R6Class( private$.outputs <- list() private$.outputOptions <- list() - # Copy app-level options - self$options <- getCurrentAppState()$options + # Copy app-level options from the owning app's state (passed from the + # WS handler closure), avoiding cross-app contamination. + if (!is.null(appState)) { + self$options <- appState$options + } else { + self$options <- getCurrentAppState()$options + } self$cache <- cachem::cache_mem(max_size = 200 * 1024^2) @@ -1070,7 +1077,13 @@ ShinySession <- R6Class( } private$unhandledErrorCallbacks$invoke(e, onError = printError) - .globals$onUnhandledErrorCallbacks$invoke(e, onError = printError) + # Invoke app-level callbacks from the owning app's state (captured at + # session creation), not the global pointer which may point to another app. + if (!is.null(private$appState)) { + private$appState$onUnhandledErrorCallbacks$invoke(e, onError = printError) + } else { + .globals$onUnhandledErrorCallbacks$invoke(e, onError = printError) + } if (close) self$close() }, @@ -2523,6 +2536,12 @@ onUnhandledError <- function(fun, session = getDefaultReactiveDomain()) { } if (is.null(session)) { + # Route to the current app's callbacks if an app is running; + # fall back to global callbacks for backward compatibility. + appState <- getCurrentAppState() + if (!is.null(appState)) { + return(appState$onUnhandledErrorCallbacks$register(fun)) + } .globals$onUnhandledErrorCallbacks$register(fun) } else { session$onUnhandledError(fun) @@ -2621,6 +2640,12 @@ flushPendingSessions <- function() { #' @export onStop <- function(fun, session = getDefaultReactiveDomain()) { if (is.null(session)) { + # Route to the current app's callbacks if an app is running; + # fall back to global callbacks for backward compatibility. + appState <- getCurrentAppState() + if (!is.null(appState)) { + return(appState$onStopCallbacks$register(fun)) + } return(.globals$onStopCallbacks$register(fun)) } else { # Note: In the future if we allow scoping the onStop() callback to modules diff --git a/R/shinyui.R b/R/shinyui.R index 6a5e35dc3..bf8cd897f 100644 --- a/R/shinyui.R +++ b/R/shinyui.R @@ -214,8 +214,10 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") { if (!isTRUE(grepl(uiPattern, req$PATH_INFO))) return(NULL) - showcaseMode <- .globals$showcaseDefault - if (.globals$showcaseOverride) { + # httpContextHandler sets currentAppState before this handler runs + appState <- getCurrentAppState() + showcaseMode <- appState$showcaseDefault + if (appState$showcaseOverride) { mode <- showcaseModeOfReq(req) if (!is.null(mode)) showcaseMode <- mode diff --git a/R/showcase.R b/R/showcase.R index 08515c20d..707a72890 100644 --- a/R/showcase.R +++ b/R/showcase.R @@ -132,7 +132,8 @@ tabContentHelper <- function(files, path, language) { showcaseCodeTabs <- function(codeLicense) { rFiles <- list.files(pattern = "\\.[rR]$") wwwFiles <- list() - if (isTRUE(.globals$IncludeWWW)) { + # httpContextHandler sets currentAppState before this handler runs + if (isTRUE(getCurrentAppState()$IncludeWWW)) { path <- file.path(getwd(), "www") wwwFiles$jsFiles <- list.files(path, pattern = "\\.js$") wwwFiles$cssFiles <- list.files(path, pattern = "\\.css$") @@ -209,8 +210,14 @@ showcaseBody <- function(htmlBody) { # Sets the defaults for showcase mode (for app boot). setShowcaseDefault <- function(showcaseDefault) { - .globals$showcaseDefault <- showcaseDefault - .globals$showcaseOverride <- as.logical(showcaseDefault) + appState <- getCurrentAppState() + if (!is.null(appState)) { + appState$showcaseDefault <- showcaseDefault + appState$showcaseOverride <- as.logical(showcaseDefault) + } else { + .globals$showcaseDefault <- showcaseDefault + .globals$showcaseOverride <- as.logical(showcaseDefault) + } } diff --git a/man/runApp.Rd b/man/runApp.Rd index 01f87766b..f7161b7b4 100644 --- a/man/runApp.Rd +++ b/man/runApp.Rd @@ -12,7 +12,8 @@ runApp( workerId = "", quiet = FALSE, display.mode = c("auto", "normal", "showcase"), - test.mode = getOption("shiny.testmode", FALSE) + test.mode = getOption("shiny.testmode", FALSE), + blocking = getOption("shiny.blocking", TRUE) ) } \arguments{ @@ -59,6 +60,23 @@ in its \code{DESCRIPTION} file, if any.} \item{test.mode}{Should the application be launched in test mode? This is only used for recording or running automated tests. Defaults to the \code{shiny.testmode} option, or FALSE if the option is not set.} + +\item{blocking}{If \code{TRUE} (the default), the function blocks and does not +return until the app is stopped. If \code{FALSE}, the app runs in the background +via \code{later} callbacks and the function returns immediately with a +\code{ShinyAppHandle} object that can be used to stop the app. The default can +be changed via \code{options(shiny.blocking = FALSE)}. Non-blocking mode +requires the \code{later} event loop to run; this happens automatically in +interactive sessions when idle at the console, but in scripts requires +calling \code{\link[later:run_now]{later::run_now()}} repeatedly.} +} +\value{ +If \code{blocking = TRUE}, returns the value passed to \code{\link[=stopApp]{stopApp()}}, or +throws an error if the app was stopped with an error. If \code{blocking = FALSE}, +returns a \code{ShinyAppHandle} object with methods \code{stop()}, \code{status()}, +\code{url()}, and \code{result()}. The \code{status()} method returns \code{"running"}, +\code{"success"}, or \code{"error"}. The \code{result()} method throws an error if called +while running, or re-throws the error if the app stopped with an error. } \description{ Runs a Shiny application. This function normally does not return; interrupt R diff --git a/man/runExample.Rd b/man/runExample.Rd index aa20b3604..7582ce068 100644 --- a/man/runExample.Rd +++ b/man/runExample.Rd @@ -10,7 +10,8 @@ runExample( launch.browser = getOption("shiny.launch.browser", interactive()), host = getOption("shiny.host", "127.0.0.1"), display.mode = c("auto", "normal", "showcase"), - package = "shiny" + package = "shiny", + blocking = getOption("shiny.blocking", TRUE) ) } \arguments{ @@ -48,6 +49,15 @@ on the subdirectory. Example apps can include a \code{DESCRIPTION} file and a \code{README.md} file to provide metadata and commentary about the example. See the article on \href{https://shiny.posit.co/r/articles/build/display-modes/}{Display Modes} on the Shiny website for more information.} + +\item{blocking}{If \code{TRUE} (the default), the function blocks and does not +return until the app is stopped. If \code{FALSE}, the app runs in the background +via \code{later} callbacks and the function returns immediately with a +\code{ShinyAppHandle} object that can be used to stop the app. The default can +be changed via \code{options(shiny.blocking = FALSE)}. Non-blocking mode +requires the \code{later} event loop to run; this happens automatically in +interactive sessions when idle at the console, but in scripts requires +calling \code{\link[later:run_now]{later::run_now()}} repeatedly.} } \description{ Launch Shiny example applications, and optionally, your system's web browser. diff --git a/man/runGadget.Rd b/man/runGadget.Rd index 06acc9143..b324e3ae5 100644 --- a/man/runGadget.Rd +++ b/man/runGadget.Rd @@ -9,7 +9,8 @@ runGadget( server = NULL, port = getOption("shiny.port"), viewer = paneViewer(), - stopOnCancel = TRUE + stopOnCancel = TRUE, + blocking = getOption("shiny.blocking", TRUE) ) } \arguments{ @@ -29,9 +30,21 @@ dialog window, or external browser--by passing in a call to one of the is automatically created that handles \code{input$cancel} by calling \code{stopApp()} with an error. Pass \code{FALSE} if you want to handle \code{input$cancel} yourself.} + +\item{blocking}{If \code{TRUE} (the default), the function blocks and does not +return until the app is stopped. If \code{FALSE}, the app runs in the background +via \code{later} callbacks and the function returns immediately with a +\code{ShinyAppHandle} object that can be used to stop the app. The default can +be changed via \code{options(shiny.blocking = FALSE)}. Non-blocking mode +requires the \code{later} event loop to run; this happens automatically in +interactive sessions when idle at the console, but in scripts requires +calling \code{\link[later:run_now]{later::run_now()}} repeatedly.} } \value{ -The value returned by the gadget. +If \code{blocking = TRUE} (the default), returns the value passed to +\code{\link[=stopApp]{stopApp()}} by the gadget. If \code{blocking = FALSE}, returns a +\code{ShinyAppHandle} object; use \code{handle$result()} to retrieve the gadget's +return value after it stops. } \description{ Similar to \code{runApp}, but handles \code{input$cancel} automatically, and diff --git a/tests/testthat/_snaps/tabPanel.md b/tests/testthat/_snaps/tabPanel.md index 713cca41f..a4eb4f478 100644 --- a/tests/testthat/_snaps/tabPanel.md +++ b/tests/testthat/_snaps/tabPanel.md @@ -353,7 +353,7 @@