Nothing
#' HTTP and WebSocket server
#'
#' Allows R code to listen for and interact with HTTP and WebSocket clients, so
#' you can serve web traffic directly out of your R process. Implementation is
#' based on \href{https://github.com/joyent/libuv}{libuv} and
#' \href{https://github.com/nodejs/http-parser}{http-parser}.
#'
#' This is a low-level library that provides little more than network I/O and
#' implementations of the HTTP and WebSocket protocols. For an easy way to
#' create web applications, try \href{https://shiny.posit.co}{Shiny} instead.
#'
#' @examples
#' \dontrun{
#' demo("echo", package="httpuv")
#' }
#'
#' @seealso \link{startServer}
#'
#' @name httpuv-package
#' @aliases httpuv
#' @docType package
#' @title HTTP and WebSocket server
#' @author Joe Cheng \email{joe@@rstudio.com}
#' @keywords package
#' @useDynLib httpuv
#' @importFrom Rcpp evalCpp
NULL
# Implementation of Rook input stream
InputStream <- R6Class(
'InputStream',
public = list(
initialize = function(conn, length) {
private$conn <- conn
private$length <- length
seek(private$conn, 0)
},
read_lines = function(n = -1L) {
readLines(private$conn, n, warn = FALSE)
},
read = function(l = -1L) {
# l < 0 means read all remaining bytes
if (l < 0)
l <- private$length - seek(private$conn)
if (l == 0)
return(raw())
else
return(readBin(private$conn, raw(), l))
},
rewind = function() {
seek(private$conn, 0)
}
),
private = list(
conn = NULL,
length = NULL
),
cloneable = FALSE
)
NullInputStream <- R6Class(
'NullInputStream',
public = list(
read_lines = function(n = -1L) {
character()
},
read = function(l = -1L) {
raw()
},
rewind = function() invisible(),
close = function() invisible()
),
cloneable = FALSE
)
nullInputStream <- NullInputStream$new()
#Implementation of Rook error stream
ErrorStream <- R6Class(
'ErrorStream',
public = list(
cat = function(... , sep = " ", fill = FALSE, labels = NULL) {
base::cat(..., sep=sep, fill=fill, labels=labels, file=stderr())
},
flush = function() {
base::flush(stderr())
}
),
cloneable = FALSE
)
stdErrStream <- ErrorStream$new()
#' @importFrom promises promise then finally is.promise %...>% %...!%
rookCall <- function(func, req, data = NULL, dataLength = -1) {
# Break the processing into two parts: first, the computation with func();
# second, the preparation of the response object.
compute <- function() {
inputStream <- if(is.null(data))
nullInputStream
else
InputStream$new(data, dataLength)
req$rook.input <- inputStream
req$rook.errors <- stdErrStream
req$httpuv.version <- httpuv_version()
# These appear to be required for Rook multipart parsing to work
if (!is.null(req$HTTP_CONTENT_TYPE))
req$CONTENT_TYPE <- req$HTTP_CONTENT_TYPE
if (!is.null(req$HTTP_CONTENT_LENGTH))
req$CONTENT_LENGTH <- req$HTTP_CONTENT_LENGTH
# func() may return a regular value or a promise.
func(req)
}
prepare_response <- function(resp) {
if (is.null(resp) || length(resp) == 0)
return(NULL)
# If headers is an empty unnamed list, convert to named list so that
# the C++ code won't error.
if (is.null(resp$headers) ||
(length(resp$headers) == 0 && is.null(names(resp$headers))))
{
resp$headers <- named_list()
}
# Coerce all headers to character
resp$headers <- lapply(resp$headers, paste)
if ('file' %in% names(resp$body)) {
filename <- resp$body[['file']]
owned <- FALSE
if ('owned' %in% names(resp$body))
owned <- as.logical(resp$body$owned)
resp$body <- NULL
resp$bodyFile <- filename
resp$bodyFileOwned <- owned
}
resp
}
on_error <- function(e) {
list(
status=500L,
headers=list(
'Content-Type'='text/plain; charset=UTF-8'
),
body=charToRaw(enc2utf8(
paste("ERROR:", conditionMessage(e), collapse="\n")
))
)
}
# First, run the compute function. If it errored, return error response.
# Then check if it returned a promise. If so, promisify the next step.
# If not, run the next step immediately.
compute_error <- NULL
response <- tryCatch(
compute(),
error = function(e) compute_error <<- e
)
if (!is.null(compute_error)) {
return(on_error(compute_error))
}
if (is.promise(response)) {
response %...>% prepare_response %...!% on_error
} else {
tryCatch(prepare_response(response), error = on_error)
}
}
AppWrapper <- R6Class(
'AppWrapper',
private = list(
app = NULL, # List defining app
wsconns = NULL, # An environment containing websocket connections
supportsOnHeaders = NULL # Logical
),
public = list(
initialize = function(app) {
if (is.function(app))
private$app <- list(call=app)
else
private$app <- app
# private$app$onHeaders can error (e.g. if private$app is a reference class)
private$supportsOnHeaders <- isTRUE(try(!is.null(private$app$onHeaders), silent=TRUE))
# staticPaths are saved in a field on this object, because they are read
# from the app object only during initialization. This is the only time
# it makes sense to read them from the app object, since they're
# subsequently used on the background thread, and for performance
# reasons it can't call back into R. Note that if the app object is a
# reference object and app$staticPaths is changed later, it will have no
# effect on the behavior of the application.
#
# If private$app is a reference class, accessing private$app$staticPaths
# can error if not present. Saving here in a separate var because R CMD
# check complains if you compare class(x) with a string.
try_obj_class <- class(try(private$app$staticPaths, silent = TRUE))
if (try_obj_class == "try-error" || is.null(private$app$staticPaths)) {
self$staticPaths <- list()
} else {
self$staticPaths <- normalizeStaticPaths(private$app$staticPaths)
}
try_obj_class <- class(try(private$app$staticPathOptions, silent = TRUE))
if (try_obj_class == "try-error" || is.null(private$app$staticPathOptions)) {
# Use defaults
self$staticPathOptions <- staticPathOptions()
} else if (inherits(private$app$staticPathOptions, "staticPathOptions")) {
self$staticPathOptions <- normalizeStaticPathOptions(private$app$staticPathOptions)
} else {
stop("staticPathOptions must be an object of class staticPathOptions.")
}
private$wsconns <- new.env(parent = emptyenv())
},
onHeaders = function(req) {
if (!private$supportsOnHeaders)
return(NULL)
rookCall(private$app$onHeaders, req)
},
onBodyData = function(req, bytes) {
if (is.null(req$.bodyData))
req$.bodyData <- file(open='w+b', encoding='UTF-8')
writeBin(bytes, req$.bodyData)
},
call = function(req, cpp_callback) {
# The cpp_callback is an external pointer to a C++ function that writes
# the response.
resp <- if (is.null(private$app$call)) {
list(
status = 404L,
headers = list(
"Content-Type" = "text/plain"
),
body = "404 Not Found\n"
)
} else {
rookCall(private$app$call, req, req$.bodyData, seek(req$.bodyData))
}
# Note: rookCall() should never throw error because all the work is
# wrapped in tryCatch().
clean_up <- function() {
if (!is.null(req$.bodyData)) {
close(req$.bodyData)
}
req$.bodyData <- NULL
}
if (is.promise(resp)) {
# Slower path if resp is a promise
resp <- resp %...>% invokeCppCallback(., cpp_callback)
finally(resp, clean_up)
} else {
# Fast path if resp is a regular value
on.exit(clean_up())
invokeCppCallback(resp, cpp_callback)
}
invisible()
},
onWSOpen = function(handle, req) {
ws <- WebSocket$new(handle, req)
private$wsconns[[wsconn_address(handle)]] <- ws
result <- try(private$app$onWSOpen(ws))
# If an unexpected error happened, just close up
if (inherits(result, 'try-error')) {
ws$close(1011, "Error in onWSOpen")
}
},
onWSMessage = function(handle, binary, message) {
for (handler in private$wsconns[[wsconn_address(handle)]]$messageCallbacks) {
result <- try(handler(binary, message))
if (inherits(result, 'try-error')) {
private$wsconns[[wsconn_address(handle)]]$close(1011, "Error executing onWSMessage")
return()
}
}
},
onWSClose = function(handle) {
ws <- private$wsconns[[wsconn_address(handle)]]
ws$handle <- NULL
rm(list = wsconn_address(handle), envir = private$wsconns)
for (handler in ws$closeCallbacks) {
handler()
}
},
staticPaths = NULL, # List of static paths
staticPathOptions = NULL # StaticPathOptions object
)
)
#' WebSocket class
#'
#' A \code{WebSocket} object represents a single WebSocket connection. The
#' object can be used to send messages and close the connection, and to receive
#' notifications when messages are received or the connection is closed.
#'
#' Note that this WebSocket class is different from the one provided by the
#' package named websocket. This class is meant to be used on the server side,
#' whereas the one in the websocket package is to be used as a client. The
#' WebSocket class in httpuv has an older API than the one in the websocket
#' package.
#'
#' WebSocket objects should never be created directly. They are obtained by
#' passing an \code{onWSOpen} function to \code{\link{startServer}}.
#'
#' @usage NULL
#'
#' @format NULL
#'
#' @section Fields:
#'
#' \describe{
#' \item{\code{request}}{
#' The Rook request environment that opened the connection. This can be
#' used to inspect HTTP headers, for example.
#' }
#' }
#'
#'
#' @section Methods:
#'
#' \describe{
#' \item{\code{onMessage(func)}}{
#' Registers a callback function that will be invoked whenever a message
#' is received on this connection. The callback function will be invoked
#' with two arguments. The first argument is \code{TRUE} if the message
#' is binary and \code{FALSE} if it is text. The second argument is either
#' a raw vector (if the message is binary) or a character vector.
#' }
#' \item{\code{onClose(func)}}{
#' Registers a callback function that will be invoked when the connection
#' is closed.
#' }
#' \item{\code{send(message)}}{
#' Begins sending the given message over the websocket. The message must
#' be either a raw vector, or a single-element character vector that is
#' encoded in UTF-8.
#' }
#' \item{\code{close()}}{
#' Closes the websocket connection.
#' }
#' }
#'
#' @examples
#'
#' \dontrun{
#' # A WebSocket echo server that listens on port 8080
#' startServer("0.0.0.0", 8080,
#' list(
#' onHeaders = function(req) {
#' # Print connection headers
#' cat(capture.output(str(as.list(req))), sep = "\n")
#' },
#' onWSOpen = function(ws) {
#' cat("Connection opened.\n")
#'
#' ws$onMessage(function(binary, message) {
#' cat("Server received message:", message, "\n")
#' ws$send(message)
#' })
#' ws$onClose(function() {
#' cat("Connection closed.\n")
#' })
#'
#' }
#' )
#' )
#' }
#' @export
WebSocket <- R6Class(
'WebSocket',
public = list(
initialize = function(handle, req) {
self$handle <- handle
self$request <- req
},
onMessage = function(func) {
self$messageCallbacks <- c(self$messageCallbacks, func)
},
onClose = function(func) {
self$closeCallbacks <- c(self$closeCallbacks, func)
},
send = function(message) {
if (is.null(self$handle))
return()
if (is.raw(message))
sendWSMessage(self$handle, TRUE, message)
else {
# TODO: Ensure that message is UTF-8 encoded
sendWSMessage(self$handle, FALSE, as.character(message))
}
},
close = function(code = 1000L, reason = "") {
if (is.null(self$handle))
return()
# Make sure the code will fit in a short int (2 bytes); if not just use
# "Going Away" error code.
code <- as.integer(code)
if (code < 0 || code > 2^16 - 1) {
warning("Invalid websocket error code: ", code)
code <- 1001L
}
reason <- iconv(reason, to = "UTF-8")
closeWS(self$handle, code, reason)
self$handle <- NULL
},
handle = NULL,
messageCallbacks = list(),
closeCallbacks = list(),
request = NULL
)
)
#' Create an HTTP/WebSocket server
#'
#' Creates an HTTP/WebSocket server on the specified host and port.
#'
#' @param host A string that is a valid IPv4 address that is owned by this
#' server, or \code{"0.0.0.0"} to listen on all IP addresses.
#' @param port A number or integer that indicates the server port that should be
#' listened on. Note that on most Unix-like systems including Linux and macOS,
#' port numbers smaller than 1024 require root privileges.
#' @param app A collection of functions that define your application. See
#' Details.
#' @param quiet If \code{TRUE}, suppress error messages from starting app.
#' @return A handle for this server that can be passed to
#' \code{\link{stopServer}} to shut the server down.
#'
#' @details \code{startServer} binds the specified port and listens for
#' connections on an thread running in the background. This background thread
#' handles the I/O, and when it receives a HTTP request, it will schedule a
#' call to the user-defined R functions in \code{app} to handle the request.
#' This scheduling is done with \code{\link[later]{later}()}. When the R call
#' stack is empty -- in other words, when an interactive R session is sitting
#' idle at the command prompt -- R will automatically run the scheduled calls.
#' However, if the call stack is not empty -- if R is evaluating other R code
#' -- then the callbacks will not execute until either the call stack is
#' empty, or the \code{\link[later]{run_now}()} function is called. This
#' function tells R to execute any callbacks that have been scheduled by
#' \code{\link[later]{later}()}. The \code{\link{service}()} function is
#' essentially a wrapper for \code{\link[later]{run_now}()}.
#'
#' In older versions of httpuv (1.3.5 and below), it did not use a background
#' thread for I/O, and when this function was called, it did not accept
#' connections immediately. It was necessary to call \code{\link{service}}
#' repeatedly in order to actually accept and handle connections.
#'
#' If the port cannot be bound (most likely due to permissions or because it
#' is already bound), an error is raised.
#'
#' The application can also specify paths on the filesystem which will be
#' served from the background thread, without invoking \code{$call()} or
#' \code{$onHeaders()}. Files served this way will be only use a C++ code,
#' which is faster than going through R, and will not be blocked when R code
#' is executing. This can greatly improve performance when serving static
#' assets.
#'
#' The \code{app} parameter is where your application logic will be provided
#' to the server. This can be a list, environment, or reference class that
#' contains the following methods and fields:
#'
#' \describe{
#' \item{\code{call(req)}}{Process the given HTTP request, and return an
#' HTTP response (see Response Values). This method should be implemented in
#' accordance with the
#' \href{https://github.com/jeffreyhorner/Rook/blob/a5e45f751/README.md}{Rook}
#' specification. Note that httpuv augments \code{req} with an additional
#' item, \code{req$HEADERS}, which is a named character vector of request
#' headers.}
#' \item{\code{onHeaders(req)}}{Optional. Similar to \code{call}, but occurs
#' when headers are received. Return \code{NULL} to continue normal
#' processing of the request, or a Rook response to send that response,
#' stop processing the request, and ask the client to close the connection.
#' (This can be used to implement upload size limits, for example.)}
#' \item{\code{onWSOpen(ws)}}{Called back when a WebSocket connection is established.
#' The given object can be used to be notified when a message is received from
#' the client, to send messages to the client, etc. See \code{\link{WebSocket}}.}
#' \item{\code{staticPaths}}{
#' A named list of paths that will be served without invoking
#' \code{call()} or \code{onHeaders}. The name of each one is the URL
#' path, and the value is either a string referring to a local path, or an
#' object created by the \code{\link{staticPath}} function.
#' }
#' \item{\code{staticPathOptions}}{
#' A set of default options to use when serving static paths. If
#' not set or \code{NULL}, then it will use the result from calling
#' \code{\link{staticPathOptions}()} with no arguments.
#' }
#' }
#'
#' The \code{startPipeServer} variant can be used instead of
#' \code{startServer} to listen on a Unix domain socket or named pipe rather
#' than a TCP socket (this is not common).
#'
#' @section Response Values:
#'
#' The \code{call} function is expected to return a list containing the
#' following, which are converted to an HTTP response and sent to the client:
#'
#' \describe{
#' \item{\code{status}}{A numeric HTTP status code, e.g. \code{200} or
#' \code{404L}.}
#'
#' \item{\code{headers}}{A named list of HTTP headers and their values, as
#' strings. This can also be missing, an empty list, or `NULL`, in which
#' case no headers (other than the \code{Date} and \code{Content-Length}
#' headers, as required) will be added.}
#'
#' \item{\code{body}}{A string (or \code{raw} vector) to be sent as the body
#' of the HTTP response. This can also be omitted or set to \code{NULL} to
#' avoid sending any body, which is useful for HTTP \code{1xx}, \code{204},
#' and \code{304} responses, as well as responses to \code{HEAD} requests.}
#' }
#'
#' @return A \code{\link{WebServer}} or \code{\link{PipeServer}} object.
#'
#' @seealso \code{\link{stopServer}}, \code{\link{runServer}},
#' \code{\link{listServers}}, \code{\link{stopAllServers}}.
#' @aliases startPipeServer
#'
#' @examples
#' \dontrun{
#' # A very basic application
#' s <- startServer("0.0.0.0", 5000,
#' list(
#' call = function(req) {
#' list(
#' status = 200L,
#' headers = list(
#' 'Content-Type' = 'text/html'
#' ),
#' body = "Hello world!"
#' )
#' }
#' )
#' )
#'
#' s$stop()
#'
#'
#' # An application that serves static assets at the URL paths /assets and /lib
#' s <- startServer("0.0.0.0", 5000,
#' list(
#' call = function(req) {
#' list(
#' status = 200L,
#' headers = list(
#' 'Content-Type' = 'text/html'
#' ),
#' body = "Hello world!"
#' )
#' },
#' staticPaths = list(
#' "/assets" = "content/assets/",
#' "/lib" = staticPath(
#' "content/lib",
#' indexhtml = FALSE
#' ),
#' # This subdirectory of /lib should always be handled by the R code path
#' "/lib/dynamic" = excludeStaticPath()
#' ),
#' staticPathOptions = staticPathOptions(
#' indexhtml = TRUE
#' )
#' )
#' )
#'
#' s$stop()
#' }
#' @export
startServer <- function(host, port, app, quiet = FALSE) {
WebServer$new(host, port, app, quiet)
}
#' @param name A string that indicates the path for the domain socket (on
#' Unix-like systems) or the name of the named pipe (on Windows).
#' @param mask If non-\code{NULL} and non-negative, this numeric value is used
#' to temporarily modify the process's umask while the domain socket is being
#' created. To ensure that only root can access the domain socket, use
#' \code{strtoi("777", 8)}; or to allow owner and group read/write access, use
#' \code{strtoi("117", 8)}. If the value is \code{NULL} then the process's
#' umask is left unchanged. (This parameter has no effect on Windows.)
#' @rdname startServer
#' @export
startPipeServer <- function(name, mask, app, quiet = FALSE) {
PipeServer$new(name, mask, app, quiet)
}
#' Process requests
#'
#' Process HTTP requests and WebSocket messages. If there is nothing on R's call
#' stack -- if R is sitting idle at the command prompt -- it is not necessary to
#' call this function, because requests will be handled automatically. However,
#' if R is executing code, then requests will not be handled until either the
#' call stack is empty, or this function is called (or alternatively,
#' \code{\link[later]{run_now}} is called).
#'
#' In previous versions of httpuv (1.3.5 and below), even if a server created by
#' \code{\link{startServer}} exists, no requests were serviced unless and until
#' \code{service} was called.
#'
#' This function simply calls \code{\link[later]{run_now}()}, so if your
#' application schedules any \code{\link[later]{later}} callbacks, they will be
#' invoked.
#'
#' @param timeoutMs Approximate number of milliseconds to run before returning.
#' It will return this duration has elapsed. If 0 or Inf, then the function
#' will continually process requests without returning unless an error occurs.
#' If NA, performs a non-blocking run without waiting.
#'
#' @examples
#' \dontrun{
#' while (TRUE) {
#' service()
#' }
#' }
#'
#' @export
#' @importFrom later run_now
service <- function(timeoutMs = ifelse(interactive(), 100, 1000)) {
# In all cases, call `run_now` with `all = FALSE` so that if there is a lot of
# incoming traffic (relative to the time it takes to process it) we give the
# owning event loop opportunities to do housekeeping in between httpuv related
# callbacks.
if (is.na(timeoutMs)) {
# NA means to run non-blocking
run_now(0, all = FALSE)
} else if (timeoutMs == 0 || timeoutMs == Inf) {
.globals$paused <- FALSE
# In interactive sessions, wait for a max of 0.1 seconds for better
# responsiveness when the user sends an interrupt (like Esc in RStudio.)
check_time <- if (interactive()) 0.1 else Inf
while (!.globals$paused) {
run_now(check_time, all = FALSE)
}
} else {
# No need to check for .globals$paused because if run_now() executes
# anything, it will return immediately.
run_now(timeoutMs / 1000, all = FALSE)
}
# Some code expects service() to return TRUE (#123)
TRUE
}
#' Run a server
#'
#' This is a convenience function that provides a simple way to call
#' \code{\link{startServer}}, \code{\link{service}}, and
#' \code{\link{stopServer}} in the correct sequence. It does not return unless
#' interrupted or an error occurs.
#'
#' If you have multiple hosts and/or ports to listen on, call the individual
#' functions instead of \code{runServer}.
#'
#' @param host A string that is a valid IPv4 or IPv6 address that is owned by
#' this server, which the application will listen on. \code{"0.0.0.0"}
#' represents all IPv4 addresses and \code{"::/0"} represents all IPv6
#' addresses.
#' @param port A number or integer that indicates the server port that should be
#' listened on. Note that on most Unix-like systems including Linux and macOS,
#' port numbers smaller than 1024 require root privileges.
#' @param app A collection of functions that define your application. See
#' \code{\link{startServer}}.
#' @param interruptIntervalMs Deprecated (last used in httpuv 1.3.5).
#'
#' @seealso \code{\link{startServer}}, \code{\link{service}},
#' \code{\link{stopServer}}
#'
#' @examples
#' \dontrun{
#' # A very basic application
#' runServer("0.0.0.0", 5000,
#' list(
#' call = function(req) {
#' list(
#' status = 200L,
#' headers = list(
#' 'Content-Type' = 'text/html'
#' ),
#' body = "Hello world!"
#' )
#' }
#' )
#' )
#' }
#' @export
runServer <- function(host, port, app, interruptIntervalMs = NULL) {
server <- startServer(host, port, app)
on.exit(stopServer(server))
# TODO: in the future, add deprecation message to interruptIntervalMs.
service(0)
}
#' Interrupt httpuv runloop
#'
#' Interrupts the currently running httpuv runloop, meaning
#' \code{\link{runServer}} or \code{\link{service}} will return control back to
#' the caller and no further tasks will be processed until those methods are
#' called again. Note that this may cause in-process uploads or downloads to be
#' interrupted in mid-request.
#'
#' @export
interrupt <- function() {
.globals$paused <- TRUE
}
#' Convert raw vector to Base64-encoded string
#'
#' Converts a raw vector to its Base64 encoding as a single-element character
#' vector.
#'
#' @param x A raw vector.
#'
#' @examples
#' set.seed(100)
#' result <- rawToBase64(as.raw(runif(19, min=0, max=256)))
#' stopifnot(identical(result, "TkGNDnd7z16LK5/hR2bDqzRbXA=="))
#'
#' @export
rawToBase64 <- function(x) {
base64encode(x)
}
.globals <- new.env()
#' Create an HTTP/WebSocket daemonized server (deprecated)
#'
#' This function will be removed in a future release of httpuv. It is simply a
#' wrapper for \code{\link{startServer}}. In previous versions of httpuv (1.3.5
#' and below), \code{startServer} ran applications in the foreground and
#' \code{startDaemonizedServer} ran applications in the background, but now both
#' of them run applications in the background.
#'
#' @inheritParams startServer
#' @export
startDaemonizedServer <- startServer
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.