shiny/R/server.R

resolve <- function(dir, relpath) {
  abs.path <- file.path(dir, relpath)
  if (!file.exists(abs.path))
    return(NULL)
  abs.path <- normalizePath(abs.path, winslash='/', mustWork=TRUE)
  dir <- normalizePath(dir, winslash='/', mustWork=TRUE)
  # trim the possible trailing slash under Windows (#306)
  if (.Platform$OS.type == 'windows') dir <- sub('/$', '', dir)
  if (nchar(abs.path) <= nchar(dir) + 1)
    return(NULL)
  if (substr(abs.path, 1, nchar(dir)) != dir ||
    substr(abs.path, nchar(dir)+1, nchar(dir)+1) != '/') {
    return(NULL)
  }
  return(abs.path)
}

httpResponse <- function(status = 200,
                         content_type = "text/html; charset=UTF-8",
                         content = "",
                         headers = list()) {
  # Make sure it's a list, not a vector
  headers <- as.list(headers)
  if (is.null(headers$`X-UA-Compatible`))
    headers$`X-UA-Compatible` <- "chrome=1"
  resp <- list(status = status, content_type = content_type, content = content,
               headers = headers)
  class(resp) <- 'httpResponse'
  return(resp)
}

httpServer <- function(handlers, sharedSecret) {
  handler <- joinHandlers(handlers)

  # TODO: Figure out what this means after httpuv migration
  filter <- getOption('shiny.http.response.filter', NULL)
  if (is.null(filter))
    filter <- function(req, response) response

  function(req) {
    if (!is.null(sharedSecret)
        && !identical(sharedSecret, req$HTTP_SHINY_SHARED_SECRET)) {
      return(list(status=403,
                  body='<h1>403 Forbidden</h1><p>Shared secret mismatch</p>',
                  headers=list('Content-Type' = 'text/html')))
    }

    response <- handler(req)
    if (is.null(response))
      response <- httpResponse(404, content="<h1>Not Found</h1>")

    headers <- as.list(response$headers)
    headers$'Content-Type' <- response$content_type

    response <- filter(req, response)
    return(list(status=response$status,
                body=response$content,
                headers=headers))
  }
}

joinHandlers <- function(handlers) {
  handlers <- lapply(handlers, function(h) {
    if (is.character(h))
      return(staticHandler(h))
    else
      return(h)
  })

  # Filter out NULL
  handlers <- handlers[!sapply(handlers, is.null)]

  if (length(handlers) == 0)
    return(function(req) NULL)
  if (length(handlers) == 1)
    return(handlers[[1]])

  function(req) {
    for (handler in handlers) {
      response <- handler(req)
      if (!is.null(response))
        return(response)
    }
    return(NULL)
  }
}

reactLogHandler <- function(req) {
  if (!identical(req$PATH_INFO, '/reactlog'))
    return(NULL)

  if (!getOption('shiny.reactlog', FALSE)) {
    return(NULL)
  }

  return(httpResponse(
    status=200,
    content=list(file=renderReactLog(), owned=TRUE)
  ))
}

sessionHandler <- function(req) {
  path <- req$PATH_INFO
  if (is.null(path))
    return(NULL)

  matches <- regmatches(path, regexec('^(/session/([0-9a-f]+))(/.*)$', path))
  if (length(matches[[1]]) == 0)
    return(NULL)

  session <- matches[[1]][3]
  subpath <- matches[[1]][4]

  shinysession <- appsByToken$get(session)
  if (is.null(shinysession))
    return(NULL)

  subreq <- as.environment(as.list(req, all.names=TRUE))
  subreq$PATH_INFO <- subpath
  subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, matches[[1]][2], sep='')

  return(shinysession$handleRequest(subreq))
}

dynamicHandler <- function(filePath, dependencyFiles=filePath) {
  lastKnownTimestamps <- NA
  metaHandler <- function(req) NULL

  if (!file.exists(filePath))
    return(metaHandler)

  cacheContext <- CacheContext$new()

  return (function(req) {
    # Check if we need to rebuild
    if (cacheContext$isDirty()) {
      cacheContext$reset()
      for (dep in dependencyFiles)
        cacheContext$addDependencyFile(dep)

      clearClients()
      if (file.exists(filePath)) {
        local({
          cacheContext$with(function() {
            sys.source(filePath, envir=new.env(parent=globalenv()), keep.source=TRUE)
          })
        })
      }
      metaHandler <<- joinHandlers(.globals$clients)
      clearClients()
    }

    return(metaHandler(req))
  })
}

staticHandler <- function(root) {
  return(function(req) {
    if (!identical(req$REQUEST_METHOD, 'GET'))
      return(NULL)

    path <- req$PATH_INFO

    if (is.null(path))
      return(httpResponse(400, content="<h1>Bad Request</h1>"))

    if (path == '/')
      path <- '/index.html'

    abs.path <- resolve(root, path)
    if (is.null(abs.path))
      return(NULL)

    ext <- tools::file_ext(abs.path)
    content.type <- getContentType(ext)
    response.content <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
    return(httpResponse(200, content.type, response.content))
  })
}

appsByToken <- Map$new()

# Create a map for input handlers and register the defaults.
inputHandlers <- Map$new()

#' Register an Input Handler
#'
#' Adds an input handler for data of this type. When called, Shiny will use the
#' function provided to refine the data passed back from the client (after being
#' deserialized by RJSONIO) before making it available in the \code{input}
#' variable of the \code{server.R} file.
#'
#' This function will register the handler for the duration of the R process
#' (unless Shiny is explicitly reloaded). For that reason, the \code{type} used
#' should be very specific to this package to minimize the risk of colliding
#' with another Shiny package which might use this data type name. We recommend
#' the format of "packageName.widgetName".
#'
#' Currently Shiny registers the following handlers: \code{shiny.matrix},
#' \code{shiny.number}, and \code{shiny.date}.
#'
#' The \code{type} of a custom Shiny Input widget will be deduced using the
#' \code{getType()} JavaScript function on the registered Shiny inputBinding.
#' @param type The type for which the handler should be added -- should be a
#' single-element character vector.
#' @param fun The handler function. This is the function that will be used to
#'   parse the data delivered from the client before it is available in the
#'   \code{input} variable. The function will be called with the following three
#'   parameters:
#'    \enumerate{
#'      \item{The value of this input as provided by the client, deserialized
#'      using RJSONIO.}
#'      \item{The \code{shinysession} in which the input exists.}
#'      \item{The name of the input.}
#'    }
#' @param force If \code{TRUE}, will overwrite any existing handler without
#' warning. If \code{FALSE}, will throw an error if this class already has
#' a handler defined.
#' @examples
#' \dontrun{
#' # Register an input handler which rounds a input number to the nearest integer
#' registerInputHandler("mypackage.validint", function(x, shinysession, name) {
#'   if (is.null(x)) return(NA)
#'   round(x)
#' })
#'
#' ## On the Javascript side, the associated input binding must have a corresponding getType method:
#' getType: function(el) {
#'   return "mypackage.validint";
#' }
#'
#' }
#' @seealso \code{\link{removeInputHandler}}
#' @export
registerInputHandler <- function(type, fun, force=FALSE){
  if (inputHandlers$containsKey(type) && !force){
    stop("There is already an input handler for type: ", type)
  }
  inputHandlers$set(type, fun)
}

#' Deregister an Input Handler
#'
#' Removes an Input Handler. Rather than using the previously specified handler
#' for data of this type, the default RJSONIO serialization will be used.
#'
#' @param type The type for which handlers should be removed.
#' @return The handler previously associated with this \code{type}, if one
#'   existed. Otherwise, \code{NULL}.
#' @seealso \code{\link{registerInputHandler}}
#' @export
removeInputHandler <- function(type){
  inputHandlers$remove(type)
}

# Takes a list-of-lists and returns a matrix. The lists
# must all be the same length. NULL is replaced by NA.
registerInputHandler("shiny.matrix", function(data, ...) {
  if (length(data) == 0)
    return(matrix(nrow=0, ncol=0))

  m <- matrix(unlist(lapply(data, function(x) {
    sapply(x, function(y) {
      ifelse(is.null(y), NA, y)
    })
  })), nrow = length(data[[1]]), ncol = length(data))
  return(m)
})

registerInputHandler("shiny.number", function(val, ...){
  ifelse(is.null(val), NA, val)
})

registerInputHandler("shiny.date", function(val, ...){
  # First replace NULLs with NA, then convert to Date vector
  datelist <- ifelse(lapply(val, is.null), NA, val)
  as.Date(unlist(datelist))
})


# Provide a character representation of the WS that can be used
# as a key in a Map.
wsToKey <- function(WS) {
  as.character(WS$socket)
}

.globals <- new.env()

.globals$clients <- function(req) NULL


clearClients <- function() {
  .globals$clients <- function(req) NULL
}


registerClient <- function(client) {
  .globals$clients <- append(.globals$clients, client)
}


.globals$resources <- list()

.globals$showcaseDefault <- 0

.globals$showcaseOverride <- FALSE

#' Resource Publishing
#'
#' Adds a directory of static resources to Shiny's web server, with the given
#' path prefix. Primarily intended for package authors to make supporting
#' JavaScript/CSS files available to their components.
#'
#' @param prefix The URL prefix (without slashes). Valid characters are a-z,
#'   A-Z, 0-9, hyphen, and underscore; and must begin with a-z or A-Z. For
#'   example, a value of 'foo' means that any request paths that begin with
#'   '/foo' will be mapped to the given directory.
#' @param directoryPath The directory that contains the static resources to be
#'   served.
#'
#' @details You can call \code{addResourcePath} multiple times for a given
#'   \code{prefix}; only the most recent value will be retained. If the
#'   normalized \code{directoryPath} is different than the directory that's
#'   currently mapped to the \code{prefix}, a warning will be issued.
#'
#' @seealso \code{\link{singleton}}
#'
#' @examples
#' addResourcePath('datasets', system.file('data', package='datasets'))
#'
#' @export
addResourcePath <- function(prefix, directoryPath) {
  prefix <- prefix[1]
  if (!grepl('^[a-z][a-z0-9\\-_]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
    stop("addResourcePath called with invalid prefix; please see documentation")
  }

  if (prefix %in% c('shared')) {
    stop("addResourcePath called with the reserved prefix '", prefix, "'; ",
         "please use a different prefix")
  }

  directoryPath <- normalizePath(directoryPath, mustWork=TRUE)

  existing <- .globals$resources[[prefix]]

  if (!is.null(existing)) {
    if (existing$directoryPath != directoryPath) {
      warning("Overriding existing prefix ", prefix, " => ",
              existing$directoryPath)
    }
  }

  message('Shiny URLs starting with /', prefix, ' will mapped to ', directoryPath)

  .globals$resources[[prefix]] <- list(directoryPath=directoryPath,
                                       func=staticHandler(directoryPath))
}

resourcePathHandler <- function(req) {
  if (!identical(req$REQUEST_METHOD, 'GET'))
    return(NULL)

  path <- req$PATH_INFO

  match <- regexpr('^/([^/]+)/', path, perl=TRUE)
  if (match == -1)
    return(NULL)
  len <- attr(match, 'capture.length')
  prefix <- substr(path, 2, 2 + len - 1)

  resInfo <- .globals$resources[[prefix]]
  if (is.null(resInfo))
    return(NULL)

  suffix <- substr(path, 2 + len, nchar(path))

  subreq <- as.environment(as.list(req, all.names=TRUE))
  subreq$PATH_INFO <- suffix
  subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, substr(path, 1, 2 + len), sep='')

  return(resInfo$func(subreq))
}

.globals$server <- NULL
#' Define Server Functionality
#'
#' Defines the server-side logic of the Shiny application. This generally
#' involves creating functions that map user inputs to various kinds of output.
#'
#' @param func The server function for this application. See the details section
#'   for more information.
#'
#' @details
#' Call \code{shinyServer} from your application's \code{server.R} file, passing
#' in a "server function" that provides the server-side logic of your
#' application.
#'
#' The server function will be called when each client (web browser) first loads
#' the Shiny application's page. It must take an \code{input} and an
#' \code{output} parameter. Any return value will be ignored. It also takes an
#' optional \code{session} parameter, which is used when greater control is
#' needed.
#'
#' See the \href{http://rstudio.github.com/shiny/tutorial/}{tutorial} for more
#' on how to write a server function.
#'
#' @examples
#' \dontrun{
#' # A very simple Shiny app that takes a message from the user
#' # and outputs an uppercase version of it.
#' shinyServer(function(input, output, session) {
#'   output$uppercase <- renderText({
#'     toupper(input$message)
#'   })
#' })
#' }
#'
#' @export
shinyServer <- function(func) {
  .globals$server <- func
  if (!is.null(func))
  {
    # Tag this function as the Shiny server function. A debugger may use this
    # tag to give this function special treatment.
    attr(.globals$server, "shinyServerFunction") <- TRUE
    registerDebugHook("server", .globals, "Server Function")
  }
  invisible()
}

decodeMessage <- function(data) {
  readInt <- function(pos) {
    packBits(rawToBits(data[pos:(pos+3)]), type='integer')
  }

  if (readInt(1) != 0x01020202L)
    return(fromJSON(rawToChar(data), asText=TRUE, simplify=FALSE))

  i <- 5
  parts <- list()
  while (i <= length(data)) {
    length <- readInt(i)
    i <- i + 4
    if (length != 0)
      parts <- append(parts, list(data[i:(i+length-1)]))
    else
      parts <- append(parts, list(raw(0)))
    i <- i + length
  }

  mainMessage <- decodeMessage(parts[[1]])
  mainMessage$blobs <- parts[2:length(parts)]
  return(mainMessage)
}

# Combine dir and (file)name into a file path. If a file already exists with a
# name differing only by case, then use it instead.
file.path.ci <- function(dir, name) {
  default <- file.path(dir, name)
  if (file.exists(default))
    return(default)
  if (!file.exists(dir))
    return(default)

  matches <- list.files(dir, name, ignore.case=TRUE, full.names=TRUE,
                        include.dirs=TRUE)
  if (length(matches) == 0)
    return(default)
  return(matches[[1]])
}

# Instantiates the app in the current working directory.
createAppDir <- function() {
  globalR <- file.path.ci(getwd(), 'global.R')
  uiR <- file.path.ci(getwd(), 'ui.R')
  serverR <- file.path.ci(getwd(), 'server.R')
  wwwDir <- file.path.ci(getwd(), 'www')

  if (!file.exists(uiR) && !file.exists(wwwDir))
    stop(paste("Neither ui.R nor a www subdirectory was found in", getwd()))
  if (!file.exists(serverR))
    stop(paste("server.R file was not found in", getwd()))

  if (file.exists(globalR))
    sys.source(globalR, envir=globalenv(), keep.source=TRUE)

  shinyServer(NULL)
  serverFileTimestamp <- file.info(serverR)$mtime
  sys.source(serverR, envir=new.env(parent=globalenv()), keep.source=TRUE)
  if (is.null(.globals$server))
    stop("No server was defined in server.R")

  serverFunc <- .globals$server

  serverFuncSource <- function() {
    # Check if server.R has changed, and if so, reload
    mtime <- file.info(serverR)$mtime
    if (!identical(mtime, serverFileTimestamp)) {
      shinyServer(NULL)
      serverFileTimestamp <<- mtime
      sys.source(serverR, envir=new.env(parent=globalenv()), keep.source=TRUE)
      if (is.null(.globals$server))
        stop("No server was defined in server.R")
      serverFunc <<- .globals$server
    }
    return(serverFunc)
  }

  list(
    httpHandlers = c(dynamicHandler(uiR), wwwDir),
    serverFuncSource = serverFuncSource
  )
}

createAppObj <- function(ui, serverFunc) {
  uiHandler <- function(req) {
    if (!identical(req$REQUEST_METHOD, 'GET'))
      return(NULL)

    if (req$PATH_INFO != '/')
      return(NULL)

    textConn <- textConnection(NULL, "w")
    on.exit(close(textConn))

    renderPage(ui, textConn)
    html <- paste(textConnectionValue(textConn), collapse='\n')
    return(httpResponse(200, content=html))
  }

  list(
    httpHandlers = uiHandler,
    serverFuncSource = function() { serverFunc }
  )
}

proxyCallbacks <- function(prefix, targetCallbacks) {
  force(prefix)
  force(targetCallbacks)

  if (identical("", prefix))
    return(targetCallbacks)

  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
    stop("Invalid URL prefix \"", prefix, "\"")
  }

  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
  matchReq <- function(req) {
    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
      req <- as.environment(as.list(req))
      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
      req$PATH_INFO <- pathInfo
      return(req)
    } else {
      return(NULL)
    }
  }

  list(
    onHeaders = function(req) {
      if (identical(req$PATH_INFO, prefix)) {
        # We could return a 302 response here, but doing so seems to cause
        # httpuv to report "ERROR: [on_request_read] parse error" for some
        # reason. Instead, let the request proceed as normal and handle it
        # in call().
        return(NULL)
      }
      req <- matchReq(req)
      if (is.null(req))
        return(FALSE)
      else
        return(targetCallbacks$onHeaders(req))
    },
    call = function(req) {
      if (identical(req$PATH_INFO, prefix)) {
        return(list(
          status = 302L,
          headers = list(
            "Location" = paste(prefix, "/", sep = ""),
            "Content-Type" = "text/plain"
          ),
          body = ""
        ))
      }

      req <- matchReq(req)
      if (is.null(req))
        return(FALSE)
      else
        return(targetCallbacks$call(req))
    },
    onWSOpen = function(ws) {
      req <- matchReq(ws$request)
      if (is.null(req))
        return(FALSE)
      else {
        ws$request <- req
        return(targetCallbacks$onWSOpen(ws))
      }
    }
  )
}

createAppCallbacks <- function(httpHandlers, serverFuncSource, workerId) {

  sys.www.root <- system.file('www', package='shiny')

  # This value, if non-NULL, must be present on all HTTP and WebSocket
  # requests as the Shiny-Shared-Secret header or else access will be
  # denied (403 response for HTTP, and instant close for websocket).
  sharedSecret <- getOption('shiny.sharedSecret', NULL)

  httpuvCallbacks <- list(
    onHeaders = function(req) {
      maxSize <- getOption('shiny.maxRequestSize', 5 * 1024 * 1024)
      if (maxSize <= 0)
        return(NULL)

      reqSize <- 0
      if (length(req$CONTENT_LENGTH) > 0)
        reqSize <- as.numeric(req$CONTENT_LENGTH)
      else if (length(req$HTTP_TRANSFER_ENCODING) > 0)
        reqSize <- Inf

      if (reqSize > maxSize) {
        return(list(status = 413L,
                    headers = list(
                      'Content-Type' = 'text/plain'
                    ),
                    body = 'Maximum upload size exceeded'))
      }
      else {
        return(NULL)
      }
    },
    call = httpServer(c(sessionHandler,
                        httpHandlers,
                        sys.www.root,
                        resourcePathHandler,
                        reactLogHandler), sharedSecret),
    onWSOpen = function(ws) {
      if (!is.null(sharedSecret)
          && !identical(sharedSecret, ws$request$HTTP_SHINY_SHARED_SECRET)) {
        ws$close()
      }

      shinysession <- ShinySession$new(ws, workerId)
      appsByToken$set(shinysession$token, shinysession)
      showcase <- .globals$showcaseDefault

      ws$onMessage(function(binary, msg) {
        # If in showcase mode, record the session that should receive the reactive
        # log messages for the duration of the servicing of this message.
        if (showcase > 0) {
          .beginShowcaseSessionContext(shinysession)
          on.exit(.endShowcaseSessionContext(), add = TRUE)
        }

        # To ease transition from websockets-based code. Should remove once we're stable.
        if (is.character(msg))
          msg <- charToRaw(msg)

        if (getOption('shiny.trace', FALSE)) {
          if (binary)
            message("RECV ", '$$binary data$$')
          else
            message("RECV ", rawToChar(msg))
        }

        if (identical(charToRaw("\003\xe9"), msg))
          return()

        msg <- decodeMessage(msg)

        # Do our own list simplifying here. sapply/simplify2array give names to
        # character vectors, which is rarely what we want.
        if (!is.null(msg$data)) {
          for (name in names(msg$data)) {
            val <- msg$data[[name]]

            splitName <- strsplit(name, ':')[[1]]
            if (length(splitName) > 1) {
              msg$data[[name]] <- NULL

              if (!inputHandlers$containsKey(splitName[[2]])){
                # No input handler registered for this type
                stop("No handler registered for for type ", name)
              }

              msg$data[[ splitName[[1]] ]] <-
                  inputHandlers$get(splitName[[2]])(
                      val,
                      shinysession,
                      splitName[[1]] )
            }
            else if (is.list(val) && is.null(names(val))) {
              val_flat <- unlist(val, recursive = TRUE)

              if (is.null(val_flat)) {
                # This is to assign NULL instead of deleting the item
                msg$data[name] <- list(NULL)
              } else {
                msg$data[[name]] <- val_flat
              }
            }
          }
        }

        switch(
          msg$method,
          init = {

            serverFunc <- serverFuncSource()

            # Check for switching into/out of showcase mode
            if (.globals$showcaseOverride &&
                exists(".clientdata_url_search", where = msg$data)) {
              mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
              if (!is.null(mode))
                showcase <<- mode
            }

            shinysession$manageInputs(msg$data)

            # The client tells us what singletons were rendered into
            # the initial page
            if (!is.null(msg$data$.clientdata_singletons)) {
              shinysession$singletons <<- strsplit(
                msg$data$.clientdata_singletons, ',')[[1]]
            }

            local({
              args <- list(
                input=shinysession$input,
                output=.createOutputWriter(shinysession))

              # The clientData and session arguments are optional; check if
              # each exists
              if ('clientData' %in% names(formals(serverFunc)))
                args$clientData <- shinysession$clientData

              if ('session' %in% names(formals(serverFunc)))
                args$session <- shinysession$session

              do.call(serverFunc, args)
            })
          },
          update = {
            shinysession$manageInputs(msg$data)
          },
          shinysession$dispatch(msg)
        )
        shinysession$manageHiddenOutputs()

        if (exists(".shiny__stdout", globalenv()) &&
            exists("HTTP_GUID", ws$request)) {
          # safe to assume we're in shiny-server
          shiny_stdout <- get(".shiny__stdout", globalenv())

          # eNter a flushReact
          writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
                           " @ ", sprintf("%.3f", as.numeric(Sys.time())),
                           sep=""), con=shiny_stdout)
          flush(shiny_stdout)

          flushReact()

          # eXit a flushReact
          writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
                           " @ ", sprintf("%.3f", as.numeric(Sys.time())),
                           sep=""), con=shiny_stdout)
          flush(shiny_stdout)
        } else {
          flushReact()
        }
        lapply(appsByToken$values(), function(shinysession) {
          shinysession$flushOutput()
          NULL
        })
      })

      ws$onClose(function() {
        shinysession$close()
        appsByToken$remove(shinysession$token)
      })
    }
  )
  return(httpuvCallbacks)
}

httpuvCallbackSet <- local({
  callbacks <- list()
  list(
    add = function(cb) {
      if (length(callbacks) == 0)
        callbacks <<- list(cb)
      else
        callbacks <<- c(callbacks, list(cb))
    },
    clear = function() {
      callbacks <<- list()
    },
    metaCallbacks = list(
      onHeaders = function(req) {
        for (cb in callbacks) {
          result <- cb$onHeaders(req)
          if (!identical(result, FALSE))
            return(result)
        }
        stop("onHeaders: should never get here")
      },
      call = function(req) {
        for (cb in callbacks) {
          result <- cb$call(req)
          if (!identical(result, FALSE))
            return(result)
        }
        stop("call: should never get here")
      },
      onWSOpen = function(ws) {
        for (cb in callbacks) {
          result <- cb$onWSOpen(ws)
          if (!identical(result, FALSE))
            return(result)
        }
        stop("onWSOpen: should never get here")
      }
    )
  )
})

addSubAppObj <- function(appObj, workerId="") {
  appParts <- createAppObj(appObj$ui, appObj$server)
  path <- registerSubApp(appParts$httpHandlers, appParts$serverFuncSource, workerId)
  invisible(path)
}

addSubAppDir <- function(appDir, workerId="") {
  oldwd <- getwd()
  setwd(appDir)
  appParts <- tryCatch(
    createAppDir(),
    finally = setwd(oldwd)
  )
  path <- registerSubApp(appParts$httpHandlers, appParts$serverFuncSource, workerId)
  invisible(path)
}

registerSubApp <- function(httpHandlers, serverFuncSource, workerId) {
  path <- sprintf("/%s", createUniqueId(8))
  httpuvCallbacks <- proxyCallbacks(path,
    createAppCallbacks(httpHandlers, serverFuncSource, workerId))
  httpuvCallbackSet$add(httpuvCallbacks)
  return(path)
}

startApp <- function(httpHandlers, serverFuncSource, port, host, workerId, quiet) {
  httpuvCallbacks <- proxyCallbacks("",
    createAppCallbacks(httpHandlers, serverFuncSource, workerId))
  httpuvCallbackSet$add(httpuvCallbacks)

  if (is.numeric(port) || is.integer(port)) {
    if (!quiet) {
      message('\n', 'Listening on http://', host, ':', port)
    }
    return(startServer(host, port, httpuvCallbackSet$metaCallbacks))
  } else if (is.character(port)) {
    if (!quiet) {
      message('\n', 'Listening on domain socket ', port)
    }
    mask <- attr(port, 'mask')
    return(startPipeServer(port, mask, httpuvCallbackSet$metaCallbacks))
  }
}

# Run an application that was created by \code{\link{startApp}}. This
# function should normally be called in a \code{while(TRUE)} loop.
serviceApp <- function() {
  if (timerCallbacks$executeElapsed()) {
    for (shinysession in appsByToken$values()) {
      shinysession$manageHiddenOutputs()
    }

    flushReact()

    for (shinysession in appsByToken$values()) {
      shinysession$flushOutput()
    }
  }

  # If this R session is interactive, then call service() with a short timeout
  # to keep the session responsive to user input
  maxTimeout <- ifelse(interactive(), 100, 1000)

  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent()))
  service(timeout)
}

.shinyServerMinVersion <- '0.3.4'

#' Run Shiny Application
#'
#' Runs a Shiny application. This function normally does not return; interrupt
#' R to stop the application (usually by pressing Ctrl+C or Esc).
#'
#' The host parameter was introduced in Shiny 0.9.0. Its default value of
#' \code{"127.0.0.1"} means that, contrary to previous versions of Shiny, only
#' the current machine can access locally hosted Shiny apps. To allow other
#' clients to connect, use the value \code{"0.0.0.0"} instead (which was the
#' value that was hard-coded into Shiny in 0.8.0 and earlier).
#'
#' @param appDir The directory of the application. Should contain
#'   \code{server.R}, plus, either \code{ui.R} or a \code{www} directory that
#'   contains the file \code{index.html}. Defaults to the working directory.
#' @param port The TCP port that the application should listen on. Defaults to
#'   choosing a random port.
#' @param launch.browser If true, the system's default web browser will be
#'   launched automatically after the app is started. Defaults to true in
#'   interactive sessions only. This value of this parameter can also be a
#'   function to call with the application's URL.
#' @param host The IPv4 address that the application should listen on. Defaults
#'   to the \code{shiny.host} option, if set, or \code{"127.0.0.1"} if not. See
#'   Details.
#' @param workerId Can generally be ignored. Exists to help some editions of
#'   Shiny Server Pro route requests to the correct process.
#' @param quiet Should Shiny status messages be shown? Defaults to FALSE.
#' @param display.mode The mode in which to display the application. If set to
#'   the value \code{"showcase"}, shows application code and metadata from a
#'   \code{DESCRIPTION} file in the application directory alongside the
#'   application. If set to \code{"normal"}, displays the application normally.
#'   Defaults to \code{"auto"}, which displays the application in the mode
#'   given in its \code{DESCRIPTION} file, if any.
#'
#' @examples
#' \dontrun{
#' # Start app in the current working directory
#' runApp()
#'
#' # Start app in a subdirectory called myapp
#' runApp("myapp")
#'
#'
#' # Apps can be run without a server.r and ui.r file
#' runApp(list(
#'   ui = bootstrapPage(
#'     numericInput('n', 'Number of obs', 100),
#'     plotOutput('plot')
#'   ),
#'   server = function(input, output) {
#'     output$plot <- renderPlot({ hist(runif(input$n)) })
#'   }
#' ))
#' }
#' @export
runApp <- function(appDir=getwd(),
                   port=NULL,
                   launch.browser=getOption('shiny.launch.browser',
                                            interactive()),
                   host=getOption('shiny.host', '127.0.0.1'),
                   workerId="", quiet=FALSE,
                   display.mode=c("auto", "normal", "showcase")) {
  if (is.null(host) || is.na(host))
    host <- '0.0.0.0'

  # Make warnings print immediately
  ops <- options(warn = 1)
  on.exit(options(ops))

  if (nzchar(Sys.getenv('SHINY_PORT'))) {
    # If SHINY_PORT is set, we're running under Shiny Server. Check the version
    # to make sure it is compatible. Older versions of Shiny Server don't set
    # SHINY_SERVER_VERSION, those will return "" which is considered less than
    # any valid version.
    ver <- Sys.getenv('SHINY_SERVER_VERSION')
    if (compareVersion(ver, .shinyServerMinVersion) < 0) {
      warning('Shiny Server v', .shinyServerMinVersion,
              ' or later is required; please upgrade!')
    }
  }

  # Showcase mode is disabled by default; it must be explicitly enabled in
  # either the DESCRIPTION file for directory-based apps, or via
  # the display.mode parameter. The latter takes precedence.
  setShowcaseDefault(0)

  # If appDir specifies a path, and display mode is specified in the
  # DESCRIPTION file at that path, apply it here.
  if (is.character(appDir)) {
    desc <- file.path.ci(appDir, "DESCRIPTION")
    if (file.exists(desc)) {
      settings <- read.dcf(desc)
      if ("DisplayMode" %in% colnames(settings)) {
        mode <- settings[1,"DisplayMode"]
        if (mode == "Showcase") {
          setShowcaseDefault(1)
        }
      }
    }
  }

  # If display mode is specified as an argument, apply it (overriding the
  # value specified in DESCRIPTION, if any).
  display.mode <- match.arg(display.mode)
  if (display.mode == "normal")
    setShowcaseDefault(0)
  else if (display.mode == "showcase")
    setShowcaseDefault(1)

  require(shiny)

  # determine port if we need to
  if (is.null(port)) {

    # Try up to 20 random ports. If we don't succeed just plow ahead
    # with the final value we tried, and let the "real" startServer
    # somewhere down the line fail and throw the error to the user.
    #
    # If we (think we) succeed, save the value as .globals$lastPort,
    # and try that first next time the user wants a random port.

    for (i in 1:20) {
      if (!is.null(.globals$lastPort)) {
        port <- .globals$lastPort
        .globals$lastPort <- NULL
      }
      else {
        # Try up to 20 random ports
        port <- round(runif(1, min=3000, max=8000))
      }

      # Test port to see if we can use it
      tmp <- try(startServer(host, port, list()), silent=TRUE)
      if (!is(tmp, 'try-error')) {
        stopServer(tmp)
        .globals$lastPort <- port
        break
      }
    }
  }

  appParts <- if (is.character(appDir)) {
    orig.wd <- getwd()
    setwd(appDir)
    on.exit(setwd(orig.wd), add = TRUE)
    createAppDir()
  } else {
    createAppObj(appDir$ui, appDir$server)
  }
  server <- startApp(appParts$httpHandlers, appParts$serverFuncSource,
    port, host, workerId, quiet)

  on.exit({
    httpuvCallbackSet$clear()
    stopServer(server)
  }, add = TRUE)

  if (!is.character(port)) {
    # http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
    browseHost <- if (identical(host, "0.0.0.0")) "127.0.0.1" else host

    appUrl <- paste("http://", browseHost, ":", port, sep="")
    if (is.function(launch.browser))
      launch.browser(appUrl)
    else if (launch.browser)
      utils::browseURL(appUrl)
  } else {
    appUrl <- NULL
  }

  # call application hooks
  callAppHook("onAppStart", appUrl)
  on.exit({
    callAppHook("onAppStop", appUrl)
  }, add = TRUE)

  .globals$retval <- NULL
  .globals$stopped <- FALSE
  shinyCallingHandlers(
    while (!.globals$stopped) {
      serviceApp()
      Sys.sleep(0.001)
    }
  )

  return(.globals$retval)
}

#' Stop the currently running Shiny app
#'
#' Stops the currently running Shiny app, returning control to the caller of
#' \code{\link{runApp}}.
#'
#' @param returnValue The value that should be returned from
#'   \code{\link{runApp}}.
#'
#' @export
stopApp <- function(returnValue = NULL) {
  .globals$retval <- returnValue
  .globals$stopped <- TRUE
  httpuv::interrupt()
}

#' Run Shiny Example Applications
#'
#' Launch Shiny example applications, and optionally, your system's web browser.
#'
#' @param example The name of the example to run, or \code{NA} (the default) to
#'   list the available examples.
#' @param port The TCP port that the application should listen on. Defaults to
#'   choosing a random port.
#' @param launch.browser If true, the system's default web browser will be
#'   launched automatically after the app is started. Defaults to true in
#'   interactive sessions only.
#' @param host The IPv4 address that the application should listen on. Defaults
#'   to the \code{shiny.host} option, if set, or \code{"127.0.0.1"} if not.
#' @param display.mode The mode in which to display the example. Defaults to
#'   \code{showcase}, but may be set to \code{normal} to see the example without
#'   code or commentary.
#'
#' @examples
#' \dontrun{
#' # List all available examples
#' runExample()
#'
#' # Run one of the examples
#' runExample("01_hello")
#'
#' # Print the directory containing the code for all examples
#' system.file("examples", package="shiny")
#' }
#' @export
runExample <- function(example=NA,
                       port=NULL,
                       launch.browser=getOption('shiny.launch.browser',
                                                interactive()),
                       host=getOption('shiny.host', '127.0.0.1'),
                       display.mode=c("auto", "normal", "showcase")) {
  examplesDir <- system.file('examples', package='shiny')
  dir <- resolve(examplesDir, example)
  if (is.null(dir)) {
    if (is.na(example)) {
      errFun <- message
      errMsg <- ''
    }
    else {
      errFun <- stop
      errMsg <- paste('Example', example, 'does not exist. ')
    }

    errFun(errMsg,
           'Valid examples are "',
           paste(list.files(examplesDir), collapse='", "'),
           '"')
  }
  else {
    runApp(dir, port = port, host = host, launch.browser = launch.browser,
           display.mode = display.mode)
  }
}

# This is a wrapper for download.file and has the same interface.
# The only difference is that, if the protocol is https, it changes the
# download settings, depending on platform.
download <- function(url, ...) {
  # First, check protocol. If http or https, check platform:
  if (grepl('^https?://', url)) {

    # If Windows, call setInternet2, then use download.file with defaults.
    if (.Platform$OS.type == "windows") {
      # If we directly use setInternet2, R CMD CHECK gives a Note on Mac/Linux
      mySI2 <- `::`(utils, 'setInternet2')
      # Store initial settings
      internet2_start <- mySI2(NA)
      on.exit(mySI2(internet2_start))

      # Needed for https
      mySI2(TRUE)
      download.file(url, ...)

    } else {
      # If non-Windows, check for curl/wget/lynx, then call download.file with
      # appropriate method.

      if (nzchar(Sys.which("wget")[1])) {
        method <- "wget"
      } else if (nzchar(Sys.which("curl")[1])) {
        method <- "curl"

        # curl needs to add a -L option to follow redirects.
        # Save the original options and restore when we exit.
        orig_extra_options <- getOption("download.file.extra")
        on.exit(options(download.file.extra = orig_extra_options))

        options(download.file.extra = paste("-L", orig_extra_options))

      } else if (nzchar(Sys.which("lynx")[1])) {
        method <- "lynx"
      } else {
        stop("no download method found")
      }

      download.file(url, method = method, ...)
    }

  } else {
    download.file(url, ...)
  }
}