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