1#' @include server-input-handlers.R 2 3appsByToken <- Map$new() 4appsNeedingFlush <- Map$new() 5 6# Provide a character representation of the WS that can be used 7# as a key in a Map. 8wsToKey <- function(WS) { 9 as.character(WS$socket) 10} 11 12.globals$clients <- function(req) NULL 13 14 15clearClients <- function() { 16 .globals$clients <- function(req) NULL 17} 18 19 20registerClient <- function(client) { 21 .globals$clients <- append(.globals$clients, client) 22} 23 24 25.globals$showcaseDefault <- 0 26 27.globals$showcaseOverride <- FALSE 28 29 30#' Define Server Functionality 31#' 32#' @description \lifecycle{superseded} 33#' 34#' @description Defines the server-side logic of the Shiny application. This generally 35#' involves creating functions that map user inputs to various kinds of output. 36#' In older versions of Shiny, it was necessary to call `shinyServer()` in 37#' the `server.R` file, but this is no longer required as of Shiny 0.10. 38#' Now the `server.R` file may simply return the appropriate server 39#' function (as the last expression in the code), without calling 40#' `shinyServer()`. 41#' 42#' Call `shinyServer` from your application's `server.R` 43#' file, passing in a "server function" that provides the server-side logic of 44#' your application. 45#' 46#' The server function will be called when each client (web browser) first loads 47#' the Shiny application's page. It must take an `input` and an 48#' `output` parameter. Any return value will be ignored. It also takes an 49#' optional `session` parameter, which is used when greater control is 50#' needed. 51#' 52#' See the [tutorial](https://rstudio.github.io/shiny/tutorial/) for more 53#' on how to write a server function. 54#' 55#' @param func The server function for this application. See the details section 56#' for more information. 57#' 58#' @examples 59#' \dontrun{ 60#' # A very simple Shiny app that takes a message from the user 61#' # and outputs an uppercase version of it. 62#' shinyServer(function(input, output, session) { 63#' output$uppercase <- renderText({ 64#' toupper(input$message) 65#' }) 66#' }) 67#' 68#' 69#' # It is also possible for a server.R file to simply return the function, 70#' # without calling shinyServer(). 71#' # For example, the server.R file could contain just the following: 72#' function(input, output, session) { 73#' output$uppercase <- renderText({ 74#' toupper(input$message) 75#' }) 76#' } 77#' } 78#' @export 79#' @keywords internal 80shinyServer <- function(func) { 81 if (in_devmode()) { 82 shinyDeprecated( 83 "0.10.0", "shinyServer()", 84 details = paste0( 85 "When removing `shinyServer()`, ", 86 "ensure that the last expression returned from server.R ", 87 "is the function normally supplied to `shinyServer(func)`." 88 ) 89 ) 90 } 91 92 .globals$server <- list(func) 93 invisible(func) 94} 95 96decodeMessage <- function(data) { 97 readInt <- function(pos) { 98 packBits(rawToBits(data[pos:(pos+3)]), type='integer') 99 } 100 101 if (readInt(1) != 0x01020202L) { 102 # Treat message as UTF-8 103 charData <- rawToChar(data) 104 Encoding(charData) <- 'UTF-8' 105 return(safeFromJSON(charData, simplifyVector=FALSE)) 106 } 107 108 i <- 5 109 parts <- list() 110 while (i <= length(data)) { 111 length <- readInt(i) 112 i <- i + 4 113 if (length != 0) 114 parts <- append(parts, list(data[i:(i+length-1)])) 115 else 116 parts <- append(parts, list(raw(0))) 117 i <- i + length 118 } 119 120 mainMessage <- decodeMessage(parts[[1]]) 121 mainMessage$blobs <- parts[2:length(parts)] 122 return(mainMessage) 123} 124 125autoReloadCallbacks <- Callbacks$new() 126 127createAppHandlers <- function(httpHandlers, serverFuncSource) { 128 appvars <- new.env() 129 appvars$server <- NULL 130 131 sys.www.root <- system.file('www', package='shiny') 132 133 # This value, if non-NULL, must be present on all HTTP and WebSocket 134 # requests as the Shiny-Shared-Secret header or else access will be 135 # denied (403 response for HTTP, and instant close for websocket). 136 checkSharedSecret <- loadSharedSecret() 137 138 appHandlers <- list( 139 http = joinHandlers(c( 140 sessionHandler, 141 httpHandlers, 142 sys.www.root, 143 resourcePathHandler, 144 reactLogHandler 145 )), 146 ws = function(ws) { 147 if (!checkSharedSecret(ws$request$HTTP_SHINY_SHARED_SECRET)) { 148 ws$close() 149 return(TRUE) 150 } 151 152 if (identical(ws$request$PATH_INFO, "/autoreload/")) { 153 if (!get_devmode_option("shiny.autoreload", FALSE)) { 154 ws$close() 155 return(TRUE) 156 } 157 158 callbackHandle <- autoReloadCallbacks$register(function() { 159 ws$send("autoreload") 160 ws$close() 161 }) 162 ws$onClose(function() { 163 callbackHandle() 164 }) 165 return(TRUE) 166 } 167 168 if (!is.null(getOption("shiny.observer.error", NULL))) { 169 warning( 170 call. = FALSE, 171 "options(shiny.observer.error) is no longer supported; please unset it!" 172 ) 173 stopApp() 174 } 175 176 shinysession <- ShinySession$new(ws) 177 appsByToken$set(shinysession$token, shinysession) 178 shinysession$setShowcase(.globals$showcaseDefault) 179 180 messageHandler <- function(binary, msg) { 181 withReactiveDomain(shinysession, { 182 # To ease transition from websockets-based code. Should remove once we're stable. 183 if (is.character(msg)) 184 msg <- charToRaw(msg) 185 186 traceOption <- getOption('shiny.trace', FALSE) 187 if (isTRUE(traceOption) || traceOption == "recv") { 188 if (binary) 189 message("RECV ", '$$binary data$$') 190 else 191 message("RECV ", rawToChar(msg)) 192 } 193 194 if (isEmptyMessage(msg)) 195 return() 196 197 msg <- decodeMessage(msg) 198 199 # Set up a restore context from .clientdata_url_search before 200 # handling all the input values, because the restore context may be 201 # used by an input handler (like the one for "shiny.file"). This 202 # should only happen once, when the app starts. 203 if (is.null(shinysession$restoreContext)) { 204 bookmarkStore <- getShinyOption("bookmarkStore", default = "disable") 205 if (bookmarkStore == "disable") { 206 # If bookmarking is disabled, use empty context 207 shinysession$restoreContext <- RestoreContext$new() 208 } else { 209 # If there's bookmarked state, save it on the session object 210 shinysession$restoreContext <- RestoreContext$new(msg$data$.clientdata_url_search) 211 shinysession$createBookmarkObservers() 212 } 213 } 214 215 216 msg$data <- applyInputHandlers(msg$data) 217 218 switch( 219 msg$method, 220 init = { 221 222 serverFunc <- withReactiveDomain(NULL, serverFuncSource()) 223 if (!identicalFunctionBodies(serverFunc, appvars$server)) { 224 appvars$server <- serverFunc 225 if (!is.null(appvars$server)) 226 { 227 # Tag this function as the Shiny server function. A debugger may use this 228 # tag to give this function special treatment. 229 # It's very important that it's appvars$server itself and NOT a copy that 230 # is invoked, otherwise new breakpoints won't be picked up. 231 attr(appvars$server, "shinyServerFunction") <- TRUE 232 registerDebugHook("server", appvars, "Server Function") 233 } 234 } 235 236 # Check for switching into/out of showcase mode 237 if (.globals$showcaseOverride && 238 exists(".clientdata_url_search", where = msg$data)) { 239 mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search) 240 if (!is.null(mode)) 241 shinysession$setShowcase(mode) 242 } 243 244 # In shinysession$createBookmarkObservers() above, observers may be 245 # created, which puts the shiny session in busyCount > 0 state. That 246 # prevents the manageInputs here from taking immediate effect, by 247 # default. The manageInputs here needs to take effect though, because 248 # otherwise the bookmark observers won't find the clientData they are 249 # looking for. So use `now = TRUE` to force the changes to be 250 # immediate. 251 # 252 # FIXME: break createBookmarkObservers into two separate steps, one 253 # before and one after manageInputs, and put the observer creation 254 # in the latter. Then add an assertion that busyCount == 0L when 255 # this manageInputs is called. 256 shinysession$manageInputs(msg$data, now = TRUE) 257 258 # The client tells us what singletons were rendered into 259 # the initial page 260 if (!is.null(msg$data$.clientdata_singletons)) { 261 shinysession$singletons <- strsplit( 262 msg$data$.clientdata_singletons, ',')[[1]] 263 } 264 265 local({ 266 args <- argsForServerFunc(serverFunc, shinysession) 267 268 withReactiveDomain(shinysession, { 269 do.call( 270 # No corresponding ..stacktraceoff; the server func is pure 271 # user code 272 wrapFunctionLabel(appvars$server, "server", 273 ..stacktraceon = TRUE 274 ), 275 args 276 ) 277 }) 278 }) 279 }, 280 update = { 281 shinysession$manageInputs(msg$data) 282 }, 283 shinysession$dispatch(msg) 284 ) 285 # The HTTP_GUID, if it exists, is for Shiny Server reporting purposes 286 shinysession$startTiming(ws$request$HTTP_GUID) 287 shinysession$requestFlush() 288 289 # Make httpuv return control to Shiny quickly, instead of waiting 290 # for the usual timeout 291 httpuv::interrupt() 292 }) 293 } 294 ws$onMessage(function(binary, msg) { 295 # If unhandled errors occur, make sure they get properly logged 296 withLogErrors(messageHandler(binary, msg)) 297 }) 298 299 ws$onClose(function() { 300 shinysession$wsClosed() 301 appsByToken$remove(shinysession$token) 302 appsNeedingFlush$remove(shinysession$token) 303 }) 304 305 return(TRUE) 306 } 307 ) 308 return(appHandlers) 309} 310 311# Determine what arguments should be passed to this serverFunc. All server funcs 312# must take input and output, but clientData (obsolete) and session are 313# optional. 314argsForServerFunc <- function(serverFunc, session) { 315 args <- list(input = session$input, output = .createOutputWriter(session)) 316 317 paramNames <- names(formals(serverFunc)) 318 319 # The clientData and session arguments are optional; check if 320 # each exists 321 322 if ("clientData" %in% paramNames) 323 args$clientData <- session$clientData 324 325 if ("session" %in% paramNames) 326 args$session <- session 327 328 args 329} 330 331getEffectiveBody <- function(func) { 332 if (is.null(func)) 333 NULL 334 else if (isS4(func) && class(func) == "functionWithTrace") 335 body(func@original) 336 else 337 body(func) 338} 339 340identicalFunctionBodies <- function(a, b) { 341 identical(getEffectiveBody(a), getEffectiveBody(b)) 342} 343 344handlerManager <- HandlerManager$new() 345 346addSubApp <- function(appObj, autoRemove = TRUE) { 347 path <- createUniqueId(16, "/app") 348 appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource) 349 350 # remove the leading / from the path so a relative path is returned 351 # (needed for the case where the root URL for the Shiny app isn't /, such 352 # as portmapped URLs) 353 finalPath <- paste( 354 substr(path, 2, nchar(path)), 355 "/?w=", workerId(), 356 "&__subapp__=1", 357 sep="") 358 handlerManager$addHandler(routeHandler(path, appHandlers$http), finalPath) 359 handlerManager$addWSHandler(routeWSHandler(path, appHandlers$ws), finalPath) 360 361 if (autoRemove) { 362 # If a session is currently active, remove this subapp automatically when 363 # the current session ends 364 onReactiveDomainEnded(getDefaultReactiveDomain(), function() { 365 removeSubApp(finalPath) 366 }) 367 } 368 369 return(finalPath) 370} 371 372removeSubApp <- function(path) { 373 handlerManager$removeHandler(path) 374 handlerManager$removeWSHandler(path) 375} 376 377startApp <- function(appObj, port, host, quiet) { 378 appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource) 379 handlerManager$addHandler(appHandlers$http, "/", tail = TRUE) 380 handlerManager$addWSHandler(appHandlers$ws, "/", tail = TRUE) 381 382 httpuvApp <- handlerManager$createHttpuvApp() 383 httpuvApp$staticPaths <- c( 384 appObj$staticPaths, 385 list( 386 # Always handle /session URLs dynamically, even if / is a static path. 387 "session" = excludeStaticPath(), 388 "shared" = system.file(package = "shiny", "www", "shared") 389 ), 390 .globals$resourcePaths 391 ) 392 393 # throw an informative warning if a subdirectory of the 394 # app's www dir conflicts with another resource prefix 395 wwwDir <- httpuvApp$staticPaths[["/"]]$path 396 if (length(wwwDir)) { 397 # although httpuv allows for resource prefixes like 'foo/bar', 398 # we won't worry about conflicts in sub-sub directories since 399 # addResourcePath() currently doesn't allow it 400 wwwSubDirs <- list.dirs(wwwDir, recursive = FALSE, full.names = FALSE) 401 resourceConflicts <- intersect(wwwSubDirs, names(httpuvApp$staticPaths)) 402 if (length(resourceConflicts)) { 403 warning( 404 "Found subdirectories of your app's www/ directory that ", 405 "conflict with other resource URL prefixes. ", 406 "Consider renaming these directories: '", 407 paste0("www/", resourceConflicts, collapse = "', '"), "'", 408 call. = FALSE 409 ) 410 } 411 } 412 413 # check for conflicts in each pairwise combinations of resource mappings 414 checkResourceConflict <- function(paths) { 415 if (length(paths) < 2) return(NULL) 416 # ensure paths is a named character vector: c(resource_path = local_path) 417 paths <- vapply(paths, function(x) if (inherits(x, "staticPath")) x$path else x, character(1)) 418 # get all possible pairwise combinations of paths 419 pair_indices <- utils::combn(length(paths), 2, simplify = FALSE) 420 lapply(pair_indices, function(x) { 421 p1 <- paths[x[1]] 422 p2 <- paths[x[2]] 423 if (identical(names(p1), names(p2)) && (p1 != p2)) { 424 warning( 425 "Found multiple local file paths pointing the same resource prefix: ", names(p1), ". ", 426 "If you run into resource-related issues (e.g. 404 requests), consider ", 427 "using `addResourcePath()` and/or `removeResourcePath()` to manage resource mappings.", 428 call. = FALSE 429 ) 430 } 431 }) 432 } 433 checkResourceConflict(httpuvApp$staticPaths) 434 435 httpuvApp$staticPathOptions <- httpuv::staticPathOptions( 436 html_charset = "utf-8", 437 headers = list("X-UA-Compatible" = "IE=edge,chrome=1"), 438 validation = 439 if (!is.null(getOption("shiny.sharedSecret"))) { 440 sprintf('"Shiny-Shared-Secret" == "%s"', getOption("shiny.sharedSecret")) 441 } else { 442 character(0) 443 } 444 ) 445 446 if (is.numeric(port) || is.integer(port)) { 447 if (!quiet) { 448 hostString <- host 449 if (httpuv::ipFamily(host) == 6L) 450 hostString <- paste0("[", hostString, "]") 451 message('\n', 'Listening on http://', hostString, ':', port) 452 } 453 return(startServer(host, port, httpuvApp)) 454 } else if (is.character(port)) { 455 if (!quiet) { 456 message('\n', 'Listening on domain socket ', port) 457 } 458 mask <- attr(port, 'mask') 459 if (is.null(mask)) { 460 stop("`port` is not a valid domain socket (missing `mask` attribute). ", 461 "Note that if you're using the default `host` + `port` ", 462 "configuration (and not domain sockets), then `port` must ", 463 "be numeric, not a string.") 464 } 465 return(startPipeServer(port, mask, httpuvApp)) 466 } 467} 468 469# Run an application that was created by \code{\link{startApp}}. This 470# function should normally be called in a \code{while(TRUE)} loop. 471serviceApp <- function() { 472 timerCallbacks$executeElapsed() 473 474 flushReact() 475 flushPendingSessions() 476 477 # If this R session is interactive, then call service() with a short timeout 478 # to keep the session responsive to user input 479 maxTimeout <- ifelse(interactive(), 100, 1000) 480 481 timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent(), later::next_op_secs())) 482 service(timeout) 483 484 flushReact() 485 flushPendingSessions() 486} 487 488.shinyServerMinVersion <- '0.3.4' 489 490#' Check whether a Shiny application is running 491#' 492#' This function tests whether a Shiny application is currently running. 493#' 494#' @return `TRUE` if a Shiny application is currently running. Otherwise, 495#' `FALSE`. 496#' @export 497isRunning <- function() { 498 !is.null(getCurrentAppState()) 499} 500 501 502# Returns TRUE if we're running in Shiny Server or other hosting environment, 503# otherwise returns FALSE. 504inShinyServer <- function() { 505 nzchar(Sys.getenv('SHINY_PORT')) 506} 507 508# This check was moved out of the main function body because of an issue with 509# the RStudio debugger. (#1474) 510isEmptyMessage <- function(msg) { 511 identical(as.raw(c(0x03, 0xe9)), msg) 512} 513