R/app.R
In tjpalanca/webtools: Web Server Tools
#' @title Web Application
#'
#' @description
#'
#' ## Overview
#'
#' Web Application object based on [`fiery::Fire`] via [`Fire`] and
#' contains the following modifications:
#'
#' * Takes advantage of [`httpuv::staticPath()`] via [`Fire`] to serve,
#' assets which "happens entirely within the I/O thread, so doing so will not
#' block or be blocked by activity in the main R thread."
#' * Incorporates the [`routr`] package for routing, instead of relying on the
#' user to create it separately.
#' * Adds load testing, profiling, and benchmarking functionality for the app
#' itself and for individual routers.
#' * Methods return the `self` object to allow method chaining.
#' * Renames some methods to conform to some sort of prefixing structure for
#' better discovery.
#'
#' ## Methods
#'
#' * **Lifecycle (`lifecycle_`)**
#' * Lifecycle handlers handle starting, stopping, and other development
#' utilities for web applications.
#' * **Settings (`set_`)**
#' * set clients, headers, and other things that are globally applicable to
#' this application instance.
#' * **Data (`data`)**
#' * arbitrary data that can be set or retrieved from the object data store.
#' * **Handlers (`handle_`)**
#' * Handlers are functions that run on a specific event trigger.
#' * **Routers (`route_`)**
#' * create handlers for specific virtual paths.
#' * **Static Paths (`static_`)**
#' * create static paths for serving static files from disk.
#' * **Websockets (`ws_`)**
#' * WebSocket is a bi-directional communication protocol that is very useful
#' when you need to persistently poll or receive new information.
#' * It's also useful to set the
#' ID with `set_clients` so that they can easily be identified.
#' * **Plugins (`plugin_`)**
#' * Fiery functionality allows you to add plugins. See
#' [here](https://fiery.data-imaginist.com/articles/plugins.html) for more
#' information on how to use plugins. The interface implemented is similar
#' except that we have access to the whole object not just to the contained
#' [`Fire`] object.
#'
#' ## Details
#'
#' [Fiery Documentation](https://fiery.data-imaginist.com/reference/Fire.html)
#'
#' @param path (str) path to be hit by the request
#' @param router (str) route name
#' @param attach (str) whether to use the request, message, or header stack
#' @param url (str) URL of the request
#' @param method (str) HTTP method
#' @param base_path (str) root; stripped out of the path when handling requests
#' @param content (str) content of the request
#' @param headers (lst) list of request headers of the test request
#' @param trust (flg) indicates whether request should be trusted
#' @param message (str) message glue string
#' @param request (req) [reqres::Request] object
#' @param discard (flg) if TRUE, then selected is discarded instead of kept
#' @param .env (env) environment to be used in evaluating glue strings
#' @param event (str) name of the event to respond to
#' @param handler (fun) handler for the event
#' @param position (int) position in the handler stack; default last
#' @param name (str) human-readable name for easy identification
#' @param expr (exp) expression to execute asyncrhonously
#' @param then (fun) when `expr` is evalated, handle with this funciton
#' @param ... (arg) extra arguments
#' @param binary (flg) is the message a binary message?
#' @param close (flg) if this is not a route, then close the connection?
#'
#' @include fire.R
#' @export
App <- R6Class(
classname = "App",
inherit = Configurable,
cloneable = FALSE,
lock_class = FALSE,
lock_objects = FALSE,
public = list(
#' @description Create a new Application
#' @param host (str) IP address; defaults to all addresses.
#' @param port (int) port number from 0 to 65535.
#' @param root (str) path at which fiery will serve requests
#' @param headers (lst) global header that will be set on all responses
#' @param client_id_converter (fun) function that converts a request into
#' a client ID
#' @param path_extractor (fun) function that converts a message to
#' a path on which to dispatch
#' @param refresh_rate (num) blocking refresh rate for run cycles
#' @param refresh_rate_nb (num) non-blocking refresh rate for run cycles
#' @param trigger_dir (path) directory in which you can save RDS files
#' of lists where the `external-event` trigger will be triggered with
#' the list as arguments. See
#' [events](https://fiery.data-imaginist.com/articles/events.html).
#' @param access_log_format (str/fn) provider of the logging service.
#' @param logger (fn) logger for this application.
#' @param ... (Plugin)s to attach to this Application Instance
initialize = function(...,
host = "0.0.0.0",
port = 3838L,
root = "",
headers = NULL,
client_id_converter = function(request) {
request$trust <- TRUE
return(request$ip)
},
path_extractor = function(msg, bin) "/",
refresh_rate = 0.001,
refresh_rate_nb = 0.001,
trigger_dir = NULL,
access_log_format = common_log_format,
logger = if (interactive()) {
logger_console() # nocov
} else {
logger_null()
}) {
# Assertions
assert_string(host)
assert_int(port, lower = 0L, upper = 65535L)
assert_number(refresh_rate)
assert_number(refresh_rate_nb)
assert_string(trigger_dir, null.ok = TRUE)
assert_string(root)
assert(
test_string(access_log_format),
test_function(
access_log_format,
c("event", "message", "request", "time", "...")
)
)
assert_list(headers, null.ok = TRUE)
assert_function(client_id_converter, "request", null.ok = TRUE)
plugins <- assert_list(list(...), "Plugin")
# Set up the Fiery Server Object
fire <- Fire$new(host = host, port = port)
fire$refresh_rate <- refresh_rate
fire$refresh_rate_nb <- refresh_rate_nb
fire$trigger_dir <- trigger_dir
fire$root <- root
fire$access_log_format <- access_log_format
fire$path_extractor <- path_extractor
private$.fire <- fire
self$set_logger(logger)
if (!is.null(headers))
self$set_headers(.list = headers)
if (!is.null(client_id_converter))
self$set_client_id_converter(client_id_converter)
# Attach the plugins
walk(plugins, self$plugin_attach)
# Recast data for help
private$.events <- list(
lifecycle = list(
start = fire$events$start,
resume = fire$events$resume,
end = fire$events$end
),
cycle = list(
start = fire$events$`cycle-start`,
end = fire$events$`cycle-end`
),
request = list(
header = fire$events$header,
before = fire$events$`before-request`,
request = fire$events$request,
after = fire$events$`after-request`
),
ws = list(
before = fire$events$`before-message`,
message = fire$events$message,
after = fire$events$`after-message`,
send = fire$events$send,
closed = fire$events$`websocket-closed`
),
router = list(
router = list(
trigger = "a specific path is visited or hit",
args = c("request", "response", "keys", "..."),
return = "T/F based on whether to continue going down the handlers"
)
)
)
return(invisible(self))
},
#' @description Browse to the App URL
browse = function() {
self$fire$browse()
return(invisible(self))
},
#' @description Finalizer
finalize = function() {
self$lifecycle_stop()
},
#' @description Start the application
#' @param block (flag) blocking server
#' @param browse (flag) open a browser after starting
#' @param silent (flag) do not log to console
#' @param ... (args) passed to the `start` or `resume` handler
lifecycle_start = function(...,
block = FALSE,
browse = FALSE,
silent = FALSE) {
assert_flag(block)
assert_flag(browse)
assert_flag(silent)
# Ignite the fire
self$fire$ignite(block = block, showcase = browse, silent = silent, ...)
return(invisible(self))
},
#' @description Stop the application
lifecycle_stop = function() {
self$fire$stop()
return(invisible(self))
},
#' @description Checks if the app is still running
lifecycle_is_running = function() {
self$fire$is_running()
},
#' @description Set client converter
#' @param client_id_converter (fun) takes request and returns client ID
set_client_id_converter = function(client_id_converter) {
assert_function(client_id_converter, "request")
self$fire$set_client_id_converter(function(request) {
client_id <- client_id_converter(request)
# Handle websocket protocols
upgrade <- request$headers$Upgrade
if (!is.null(upgrade) && upgrade == "websocket") {
if (!is.null(request$query$ws)) {
client_id <- paste0(client_id, "+", request$query$ws)
}
}
# Return final client id
return(client_id)
})
return(invisible(self))
},
#' @description Set the path extractor
#' @param extractor function that takes the message and returns a path
set_path_extractor = function(extractor) {
assert_function(extractor, c("msg", "bin"))
fire <- self$fire
fire$path_extractor <- extractor
return(invisible(self))
},
#' @description Set the heaers to be sent with every response
#' @param ... (arg) key-value pairs
#' @param .list (lst) provide the values as a list
set_headers = function(..., .list = NULL) {
headers <- .list %||% list(...)
assert_list(headers, min.len = 1L, null.ok = TRUE)
assert_named(headers)
iwalk(headers, ~self$fire$header(name = .y, value = .x))
return(invisible(self))
},
#' @description Set the logger function
#' @param logger (fun) logger function; there are some presets:
#'
#' * `logger_null()` - only `error`, `warning`, `message` events
#' * `logger_console()` - everything to console
#' * `logger_file()` - everything to file
#' * `logger_switch()` - file or console dependeing on need
#'
#' Can also be any function that takes arguments: `event`, `message`,
#' `request = NULL`, `time = Sys.time()`, and `...`.
set_logger = function(logger) {
self$fire$set_logger(logger)
return(invisible(self))
},
#' @description set data inside the app object; list merge semantics
#' @param name (str) name of the data
#' @param value (arg) key value data
set_data = function(name, value) {
current <- self$fire$get_data(name)
if (is.list(current)) {
assert_list(value, names = "named")
self$fire$set_data(name, modifyList(current, value))
} else {
self$fire$set_data(name, value)
}
invisible(self)
},
#' @description get data inside the app object
#' @param name (str) name of the data
get_data = function(name) {
self$fire$get_data(name)
},
#' @description clear all data in side the app object
clear_data = function() {
self$fire$clear_data()
},
#' @description Send an application log
#' @param event (str) event attached
#' @param message (str) glue string
#' @param request (req) [reqres::Request] object
#' @param .envir (env) calling environment
log = function(event, message, request = NULL, ...,
.envir = parent.frame()) {
self$fire$log(event, glue(message, .envir = .envir), request, ...)
},
#' @description Attach a handler to an event
#' @param ... (arg) key value pairs of attributes to attach to handler
handle = function(event, name, handler, ..., position = NULL) {
assert_string(event)
assert_function(handler)
assert_int(position, null.ok = TRUE)
assert_string(name)
assert_false(name %in% map_chr(self$metadata$handles, "name"))
metadata <- assert_named(list(..., name = name))
handle_id <- self$fire$on(event, handler, pos = position)
private$set_metadata("handles",
.list = set_names(list(metadata), handle_id))
self$log("info", "Handler {handle_id} attached")
return(invisible(self))
},
#' @description Find a handler to an event
handle_find = function(..., discard = FALSE) {
private$find_element(
self$metadata$handles,
...,
discard = discard
)
},
#' @description Remove a handler
handle_remove = function(..., discard = FALSE) {
walk(
self$handle_find(..., discard = discard),
function(handle_id) {
self$fire$off(handle_id)
private$set_metadata("handles",
.list = set_names(list(NULL), handle_id))
}
)
return(invisible(self))
},
#' @description Lifecycle Handler
#'
#' Triggered once per server invocation.
#' Return value is ignored.
#'
#' **Arguments**
#'
#' * `server` - application itself
#' * `...` - extra arguments
#'
#' **Events**
#'
#' * `start/resume` - app is started, but not running; `resume` is when
#' `app_start(resume = TRUE)` is called.
#' * `end` - when app is stopped using `app_stop()`.
#'
#' @param ... (arg) key value pairs of attributes to attach to handler
handle_lifecycle = function(event = c("start", "resume", "end"),
name,
handler,
...,
position = NULL) {
event <- match_arg(event)
assert_function(handler, self$events$lifecycle[[event]]$args)
self$handle(event, name, handler, ..., position = position)
},
#' @description Cycle Handler
#'
#' Triggered for every event loop.
#' Return value is ignored.
#'
#' **Arguments**
#'
#' * `server` - application
#'
#' **Events**
#'
#' * `start` - beginning of the loop; pre-logging.
#' * `end` - end of the loop; post-logging.
#'
#' @param ... (arg) key value pairs of attributes to attach to handler
handle_cycle = function(event = c("start", "end"),
name,
handler,
...,
position = NULL) {
event <- match_arg(event)
assert_function(handler, self$events$cycle[[event]]$args)
event <- glue("cycle-{event}")
self$handle(event, name, handler, ..., position = position)
},
#' @description Request Handler
#'
#' Triggered by actual request made to the web server.
#'
#' **Arguments**
#'
#' * `server` - application itself
#' * `id` - client identifier
#' * `request` - request itself
#' * `arg_list` - for `request` event, the return value from the `before`
#' handler, if any.
#' * `response` - for `after` event, the response object
#'
#' **Events**
#'
#' * `header` - when HTTP headers are received; return `FALSE` to
#' short-circuit; return `TRUE` to continue processing
#' * `before` - before the request; for injecting session specific data to
#' request handler; return value is passed to `request` handler
#' as `arg_list`
#' * `request` - main request handling is done here; should return a valid
#' response, otherwise error 500 is raised.
#' * `after` - after the request; can be used to inspect the response
#' (but not modify it) before sending to the client;
#' return value is discarded
#'
#' @param ... (arg) key value pairs of attributes to attach to handler
handle_request = function(event = c("header", "before", "request", "after"),
name,
handler,
...,
position = NULL) {
event <- match_arg(event)
assert_function(handler, self$events$request[[event]]$args)
event <- switch(
event,
header = "header",
before = "before-request",
request = "request",
after = "after-request"
)
self$handle(event, name, handler, ..., position = position)
},
#' @description Websocket Event Handler
#'
#' **Arguments**
#'
#' * `server` - application itself
#' * `id` - client identifier
#' * `request` - request used to establish the websocket connection
#' * `message` - message itself
#' * `arg_list` - for `message` event, the return value from the `before`
#' handler, if any.
#' * `binary` - for `message` event, indicating if it is binary.
#' * `response` - for `after` event, the response object
#'
#' **Events**
#'
#' * `before` - before the request; for decoding the message before passing
#' it through; return value is passed to `request` handler
#' as `arg_list`
#' * `message` - main message handling is done here; return value discarded
#' * `after` - after the request; can be used to inspect the response
#' (but not modify it) before sending to the client;
#' return value is discarded
#' * `send` - a websocket message is sent; return value discarded
#'
#' @param ... (arg) key value pairs of attributes to attach to handler
handle_ws = function(event = c("before", "message", "after",
"send", "closed"),
name,
handler,
...,
position = NULL) {
event <- match_arg(event)
assert_function(handler, self$events$ws[[event]]$args)
event <- switch(
event,
before = "before-message",
message = "message",
after = "after-message",
send = "send",
closed = "websocket-closed"
)
self$handle(event, name, handler, ..., position = position)
},
#' @description handle Triggers an event for the handlers
#' @param event (str) event name
#' @param ... (arg) args passed to handler
#' @param check (flg) check whether this is protected
handle_trigger = function(event, ..., check = TRUE) {
self$fire$trigger(event, ..., check = check)
return(invisible(self))
},
#' @description Adds a route handler
#' @param path (str) endpoint
#' @param name (str) human-readable friendly name
#' @param methods (chr) combination of GET, POST, PUT, PATCH, DELETE
#' @param handler (fun) handler; must have arguments
#' `request`, `response`, `keys`, `...`.
#' @param attach (str) event to attach. defaults to `request`.
#' @param priority (int) relative positioning of the handler; lower will be
#' executed first.
#' @param replace (flg) whether or not to replace same name or error out
#' @param ... (dta) extra metadata to identify thion_atts route.
router = function(path,
handler,
...,
name = path,
methods = "get",
attach = "request",
priority = 0L,
replace = FALSE) {
assert_subset(attach, c("request", "message", "header"))
assert_route_handler(handler)
walk(
attach,
function(attach, metadata) {
router_id <- self$fire$on_router(
path = path,
handler = private$router_handler(handler),
name = name,
methods = methods,
attach = attach,
priority = priority,
replace = replace
)
private$set_metadata("routers", .list = set_names(
list(set_names(list(metadata), router_id)),
attach
))
self$log("info", "Router {name} on path {path} attached")
},
metadata = assert_named(list(..., name = name))
)
return(invisible(self))
},
#' @description Find routers based on metadata
#' @param ... (sel) selector expressions
router_find = function(...,
attach = c("request", "message", "header"),
discard = FALSE) {
attach <- match_arg(attach) %||% "request"
private$find_element(
self$metadata$routers[[attach]],
...,
discard = discard
)
},
#' @description Remove routers based on metadata
router_remove = function(...,
attach = c("request", "message", "header"),
discard = FALSE) {
attach <- match_arg(attach) %||% "request"
walk(
self$router_find(..., attach = attach, discard = discard),
function(router_id, attach) {
self$fire$off_router(router_id, attach = attach)
private$set_metadata(
"routers",
.list = set_names(list(set_names(list(NULL), router_id)), attach)
)
},
attach = attach
)
return(invisible(self))
},
#' @description Adds a route for server static files
#' @param path (url) URL path to serve
#' @param name (str) human-readable friendly name
#' @param file (pth) directory to serve on that path
#' @param index_html (flg) whether or not to serve when index.html exists
#' @param fallthrough (flg) if not available, use R callback
#' @param html_charset (str) html charset, defaults to UTF-8
#' @param headers (lst) headers that are included with the response
#' @param validation (chr) character vector of headers needed
#' @param replace (flg) if already exists, overwrite
#' @param ... (dta) extra metadata to identify this static path.
static = function(path, file, ...,
name = path,
index_html = TRUE,
fallthrough = FALSE,
html_charset = "utf-8",
headers = list(),
validation = character(0),
replace = FALSE) {
metadata <- assert_named(list(..., name = name))
static_id <- self$fire$on_static(
path = path,
file = file,
name = name,
index_html = index_html,
fallthrough = fallthrough,
html_charset = html_charset,
headers = headers,
validation = validation,
replace = replace
)
private$set_metadata(
"statics",
.list = set_names(list(metadata), static_id)
)
self$log("info", "Path {name} on path {path} attached")
return(invisible(self))
},
#' @description Find static paths based on metadata
static_find = function(..., discard = FALSE) {
private$find_element(
self$metadata$statics,
...,
discard = discard
)
},
#' @description Remove static paths based on metadata
static_remove = function(..., discard = FALSE) {
walk(
self$static_find(..., discard = discard),
function(static_id) {
self$fire$off_static(static_id)
private$set_metadata(
"statics",
.list = set_names(list(NULL), static_id)
)
}
)
return(invisible(self))
},
#' @description Send a websocket message
#' @param message (lst) websocket message
#' @param id (str) client identifier; all clients if missing (for send)
ws_send = function(message, id) {
if (!is.character(message))
message <- paste0(as.character(message), collapse = " ")
self$fire$send(message = message, id = id)
return(invisible(self))
},
#' @description Close a websocket connection
#' @param id (str) client identifier
ws_close = function(id) {
assert_string(id)
self$fire$close_ws_con(id)
return(invisible(self))
},
#' @description Attach a plugin
#' @param plugin (Plugin) instance
#' @param ... (arg) passed to the plugin's `on_attach` method
#' @param force (flg) force to attach even if there is already existing
#' @param bind (flg) add an active binding to fetch the plugin itself
#' @param clean (flg) remove the attach methods once they have already
#' been run to clean up the interface
plugin_attach = function(plugin, ...,
force = FALSE,
bind = TRUE,
clean = TRUE) {
# Validation
assert_class(plugin, "Plugin")
name <- assert_string(plugin$name)
if (bind & !force) assert_false(name %in% names(self))
# Either force is applied or the plugin is not yet attached
assert_true(force || !name %in% names(self$plugins))
# If force, and the plugin exists, run the detach method first.
if (name %in% names(self$plugins) && force) self$plugin_detach(name)
# If any plugins are required, ensure that they are attached
requires <- plugin$requires
if (length(requires) > 0) {
assert_character(requires)
walk(requires, ~assert_true(self$plugin_has(.)))
}
# Attach the plugin
plugin$on_attach(app = self, ...)
# Record the plugin
private$.plugins <- modifyList(
private$.plugins,
set_names(list(plugin), name)
)
# Bind the plugin
if (bind) {
if (clean) {
makeActiveBinding(
name,
function() {
clean_names <- setdiff(
names(self$plugins[[name]]),
c(".__enclos_env__", "app", "config", "requires", "name",
"initialize", "clone", "set_config", "on_attach", "on_detach",
"metadata", "fire")
)
map(clean_names, ~plugin[[.]]) %>%
set_names(clean_names)
},
self
)
} else {
makeActiveBinding(
name,
function() self$plugins[[name]],
self
)
}
}
return(invisible(self))
},
#' @description Detach a plugin
#' @param name (str) name of the plugin to detach
plugin_detach = function(name, ...) {
assert_string(name)
assert_choice(name, names(private$.plugins))
# Detach the plugin
self$plugins[[name]]$on_detach(app = self, ...)
# Remove the plugin and binding
rm(list = name, envir = self)
private$.plugins[[name]] <- NULL
return(invisible(self))
},
#' @description Detach all plugins
plugin_detach_all = function(...) {
walk(self$plugins, ~.$on_detach(app = self, ...))
private$.plugins <- list()
},
#' @description Check if a plugin of a class is attached
#' @param class (str) class of the plugin
plugin_has = function(class) {
assert_string(class)
some(self$plugins, ~test_class(., class))
},
#' @description Check if a plugin of a class is attached
#' @param class (str) class of the plugin
plugin_get = function(class) {
assert_string(class)
keep(self$plugins, ~test_class(., class)) %>%
when(length(.) == 1, .[[1]])
},
#' @description print method
print = function() print(self$fire)
),
active = list(
#' @field plugins read-only field for plugins attached
plugins = function() private$.plugins,
#' @field fire read-only field for the fire object
fire = function() private$.fire,
#' @field handles read-only field for the handles attached
handles = function() self$fire$handles,
#' @field routers read-only field for the routers attached
routers = function() self$fire$routers,
#' @field statics read-only field for the paths attached
statics = function() self$fire$statics,
#' @field data alternative way of accessing application data
data = function() self$fire$data,
#' @field sockets read-only list of active websockets
sockets = function() self$fire$sockets,
#' @field events help information
events = function() private$.events
),
private = list(
# Events help
.events = list(),
# Holds the attached plugins
.plugins = list(),
# Holds the `fiery::Fire` objects
.fire = NULL,
# Generate a router handler
router_handler = function(handler) {
function(request, response, keys, ...) {
continue <- handler(request, response, keys, ...)
response$type <- response$get_data("type") %||% response$type
if (response$status == 404L) response$status <- 200L
if (!test_flag(continue)) continue <- TRUE
return(continue)
}
}
)
)
tjpalanca/webtools documentation built on Dec. 23, 2021, 11 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' @title Web Application
#'
#' @description
#'
#' ## Overview
#'
#' Web Application object based on [`fiery::Fire`] via [`Fire`] and
#' contains the following modifications:
#'
#' * Takes advantage of [`httpuv::staticPath()`] via [`Fire`] to serve,
#' assets which "happens entirely within the I/O thread, so doing so will not
#' block or be blocked by activity in the main R thread."
#' * Incorporates the [`routr`] package for routing, instead of relying on the
#' user to create it separately.
#' * Adds load testing, profiling, and benchmarking functionality for the app
#' itself and for individual routers.
#' * Methods return the `self` object to allow method chaining.
#' * Renames some methods to conform to some sort of prefixing structure for
#' better discovery.
#'
#' ## Methods
#'
#' * **Lifecycle (`lifecycle_`)**
#' * Lifecycle handlers handle starting, stopping, and other development
#' utilities for web applications.
#' * **Settings (`set_`)**
#' * set clients, headers, and other things that are globally applicable to
#' this application instance.
#' * **Data (`data`)**
#' * arbitrary data that can be set or retrieved from the object data store.
#' * **Handlers (`handle_`)**
#' * Handlers are functions that run on a specific event trigger.
#' * **Routers (`route_`)**
#' * create handlers for specific virtual paths.
#' * **Static Paths (`static_`)**
#' * create static paths for serving static files from disk.
#' * **Websockets (`ws_`)**
#' * WebSocket is a bi-directional communication protocol that is very useful
#' when you need to persistently poll or receive new information.
#' * It's also useful to set the
#' ID with `set_clients` so that they can easily be identified.
#' * **Plugins (`plugin_`)**
#' * Fiery functionality allows you to add plugins. See
#' [here](https://fiery.data-imaginist.com/articles/plugins.html) for more
#' information on how to use plugins. The interface implemented is similar
#' except that we have access to the whole object not just to the contained
#' [`Fire`] object.
#'
#' ## Details
#'
#' [Fiery Documentation](https://fiery.data-imaginist.com/reference/Fire.html)
#'
#' @param path (str) path to be hit by the request
#' @param router (str) route name
#' @param attach (str) whether to use the request, message, or header stack
#' @param url (str) URL of the request
#' @param method (str) HTTP method
#' @param base_path (str) root; stripped out of the path when handling requests
#' @param content (str) content of the request
#' @param headers (lst) list of request headers of the test request
#' @param trust (flg) indicates whether request should be trusted
#' @param message (str) message glue string
#' @param request (req) [reqres::Request] object
#' @param discard (flg) if TRUE, then selected is discarded instead of kept
#' @param .env (env) environment to be used in evaluating glue strings
#' @param event (str) name of the event to respond to
#' @param handler (fun) handler for the event
#' @param position (int) position in the handler stack; default last
#' @param name (str) human-readable name for easy identification
#' @param expr (exp) expression to execute asyncrhonously
#' @param then (fun) when `expr` is evalated, handle with this funciton
#' @param ... (arg) extra arguments
#' @param binary (flg) is the message a binary message?
#' @param close (flg) if this is not a route, then close the connection?
#'
#' @include fire.R
#' @export
App <- R6Class(
classname = "App",
inherit = Configurable,
cloneable = FALSE,
lock_class = FALSE,
lock_objects = FALSE,
public = list(
#' @description Create a new Application
#' @param host (str) IP address; defaults to all addresses.
#' @param port (int) port number from 0 to 65535.
#' @param root (str) path at which fiery will serve requests
#' @param headers (lst) global header that will be set on all responses
#' @param client_id_converter (fun) function that converts a request into
#' a client ID
#' @param path_extractor (fun) function that converts a message to
#' a path on which to dispatch
#' @param refresh_rate (num) blocking refresh rate for run cycles
#' @param refresh_rate_nb (num) non-blocking refresh rate for run cycles
#' @param trigger_dir (path) directory in which you can save RDS files
#' of lists where the `external-event` trigger will be triggered with
#' the list as arguments. See
#' [events](https://fiery.data-imaginist.com/articles/events.html).
#' @param access_log_format (str/fn) provider of the logging service.
#' @param logger (fn) logger for this application.
#' @param ... (Plugin)s to attach to this Application Instance
initialize = function(...,
host = "0.0.0.0",
port = 3838L,
root = "",
headers = NULL,
client_id_converter = function(request) {
request$trust <- TRUE
return(request$ip)
},
path_extractor = function(msg, bin) "/",
refresh_rate = 0.001,
refresh_rate_nb = 0.001,
trigger_dir = NULL,
access_log_format = common_log_format,
logger = if (interactive()) {
logger_console() # nocov
} else {
logger_null()
}) {
# Assertions
assert_string(host)
assert_int(port, lower = 0L, upper = 65535L)
assert_number(refresh_rate)
assert_number(refresh_rate_nb)
assert_string(trigger_dir, null.ok = TRUE)
assert_string(root)
assert(
test_string(access_log_format),
test_function(
access_log_format,
c("event", "message", "request", "time", "...")
)
)
assert_list(headers, null.ok = TRUE)
assert_function(client_id_converter, "request", null.ok = TRUE)
plugins <- assert_list(list(...), "Plugin")
# Set up the Fiery Server Object
fire <- Fire$new(host = host, port = port)
fire$refresh_rate <- refresh_rate
fire$refresh_rate_nb <- refresh_rate_nb
fire$trigger_dir <- trigger_dir
fire$root <- root
fire$access_log_format <- access_log_format
fire$path_extractor <- path_extractor
private$.fire <- fire
self$set_logger(logger)
if (!is.null(headers))
self$set_headers(.list = headers)
if (!is.null(client_id_converter))
self$set_client_id_converter(client_id_converter)
# Attach the plugins
walk(plugins, self$plugin_attach)
# Recast data for help
private$.events <- list(
lifecycle = list(
start = fire$events$start,
resume = fire$events$resume,
end = fire$events$end
),
cycle = list(
start = fire$events$`cycle-start`,
end = fire$events$`cycle-end`
),
request = list(
header = fire$events$header,
before = fire$events$`before-request`,
request = fire$events$request,
after = fire$events$`after-request`
),
ws = list(
before = fire$events$`before-message`,
message = fire$events$message,
after = fire$events$`after-message`,
send = fire$events$send,
closed = fire$events$`websocket-closed`
),
router = list(
router = list(
trigger = "a specific path is visited or hit",
args = c("request", "response", "keys", "..."),
return = "T/F based on whether to continue going down the handlers"
)
)
)
return(invisible(self))
},
#' @description Browse to the App URL
browse = function() {
self$fire$browse()
return(invisible(self))
},
#' @description Finalizer
finalize = function() {
self$lifecycle_stop()
},
#' @description Start the application
#' @param block (flag) blocking server
#' @param browse (flag) open a browser after starting
#' @param silent (flag) do not log to console
#' @param ... (args) passed to the `start` or `resume` handler
lifecycle_start = function(...,
block = FALSE,
browse = FALSE,
silent = FALSE) {
assert_flag(block)
assert_flag(browse)
assert_flag(silent)
# Ignite the fire
self$fire$ignite(block = block, showcase = browse, silent = silent, ...)
return(invisible(self))
},
#' @description Stop the application
lifecycle_stop = function() {
self$fire$stop()
return(invisible(self))
},
#' @description Checks if the app is still running
lifecycle_is_running = function() {
self$fire$is_running()
},
#' @description Set client converter
#' @param client_id_converter (fun) takes request and returns client ID
set_client_id_converter = function(client_id_converter) {
assert_function(client_id_converter, "request")
self$fire$set_client_id_converter(function(request) {
client_id <- client_id_converter(request)
# Handle websocket protocols
upgrade <- request$headers$Upgrade
if (!is.null(upgrade) && upgrade == "websocket") {
if (!is.null(request$query$ws)) {
client_id <- paste0(client_id, "+", request$query$ws)
}
}
# Return final client id
return(client_id)
})
return(invisible(self))
},
#' @description Set the path extractor
#' @param extractor function that takes the message and returns a path
set_path_extractor = function(extractor) {
assert_function(extractor, c("msg", "bin"))
fire <- self$fire
fire$path_extractor <- extractor
return(invisible(self))
},
#' @description Set the heaers to be sent with every response
#' @param ... (arg) key-value pairs
#' @param .list (lst) provide the values as a list
set_headers = function(..., .list = NULL) {
headers <- .list %||% list(...)
assert_list(headers, min.len = 1L, null.ok = TRUE)
assert_named(headers)
iwalk(headers, ~self$fire$header(name = .y, value = .x))
return(invisible(self))
},
#' @description Set the logger function
#' @param logger (fun) logger function; there are some presets:
#'
#' * `logger_null()` - only `error`, `warning`, `message` events
#' * `logger_console()` - everything to console
#' * `logger_file()` - everything to file
#' * `logger_switch()` - file or console dependeing on need
#'
#' Can also be any function that takes arguments: `event`, `message`,
#' `request = NULL`, `time = Sys.time()`, and `...`.
set_logger = function(logger) {
self$fire$set_logger(logger)
return(invisible(self))
},
#' @description set data inside the app object; list merge semantics
#' @param name (str) name of the data
#' @param value (arg) key value data
set_data = function(name, value) {
current <- self$fire$get_data(name)
if (is.list(current)) {
assert_list(value, names = "named")
self$fire$set_data(name, modifyList(current, value))
} else {
self$fire$set_data(name, value)
}
invisible(self)
},
#' @description get data inside the app object
#' @param name (str) name of the data
get_data = function(name) {
self$fire$get_data(name)
},
#' @description clear all data in side the app object
clear_data = function() {
self$fire$clear_data()
},
#' @description Send an application log
#' @param event (str) event attached
#' @param message (str) glue string
#' @param request (req) [reqres::Request] object
#' @param .envir (env) calling environment
log = function(event, message, request = NULL, ...,
.envir = parent.frame()) {
self$fire$log(event, glue(message, .envir = .envir), request, ...)
},
#' @description Attach a handler to an event
#' @param ... (arg) key value pairs of attributes to attach to handler
handle = function(event, name, handler, ..., position = NULL) {
assert_string(event)
assert_function(handler)
assert_int(position, null.ok = TRUE)
assert_string(name)
assert_false(name %in% map_chr(self$metadata$handles, "name"))
metadata <- assert_named(list(..., name = name))
handle_id <- self$fire$on(event, handler, pos = position)
private$set_metadata("handles",
.list = set_names(list(metadata), handle_id))
self$log("info", "Handler {handle_id} attached")
return(invisible(self))
},
#' @description Find a handler to an event
handle_find = function(..., discard = FALSE) {
private$find_element(
self$metadata$handles,
...,
discard = discard
)
},
#' @description Remove a handler
handle_remove = function(..., discard = FALSE) {
walk(
self$handle_find(..., discard = discard),
function(handle_id) {
self$fire$off(handle_id)
private$set_metadata("handles",
.list = set_names(list(NULL), handle_id))
}
)
return(invisible(self))
},
#' @description Lifecycle Handler
#'
#' Triggered once per server invocation.
#' Return value is ignored.
#'
#' **Arguments**
#'
#' * `server` - application itself
#' * `...` - extra arguments
#'
#' **Events**
#'
#' * `start/resume` - app is started, but not running; `resume` is when
#' `app_start(resume = TRUE)` is called.
#' * `end` - when app is stopped using `app_stop()`.
#'
#' @param ... (arg) key value pairs of attributes to attach to handler
handle_lifecycle = function(event = c("start", "resume", "end"),
name,
handler,
...,
position = NULL) {
event <- match_arg(event)
assert_function(handler, self$events$lifecycle[[event]]$args)
self$handle(event, name, handler, ..., position = position)
},
#' @description Cycle Handler
#'
#' Triggered for every event loop.
#' Return value is ignored.
#'
#' **Arguments**
#'
#' * `server` - application
#'
#' **Events**
#'
#' * `start` - beginning of the loop; pre-logging.
#' * `end` - end of the loop; post-logging.
#'
#' @param ... (arg) key value pairs of attributes to attach to handler
handle_cycle = function(event = c("start", "end"),
name,
handler,
...,
position = NULL) {
event <- match_arg(event)
assert_function(handler, self$events$cycle[[event]]$args)
event <- glue("cycle-{event}")
self$handle(event, name, handler, ..., position = position)
},
#' @description Request Handler
#'
#' Triggered by actual request made to the web server.
#'
#' **Arguments**
#'
#' * `server` - application itself
#' * `id` - client identifier
#' * `request` - request itself
#' * `arg_list` - for `request` event, the return value from the `before`
#' handler, if any.
#' * `response` - for `after` event, the response object
#'
#' **Events**
#'
#' * `header` - when HTTP headers are received; return `FALSE` to
#' short-circuit; return `TRUE` to continue processing
#' * `before` - before the request; for injecting session specific data to
#' request handler; return value is passed to `request` handler
#' as `arg_list`
#' * `request` - main request handling is done here; should return a valid
#' response, otherwise error 500 is raised.
#' * `after` - after the request; can be used to inspect the response
#' (but not modify it) before sending to the client;
#' return value is discarded
#'
#' @param ... (arg) key value pairs of attributes to attach to handler
handle_request = function(event = c("header", "before", "request", "after"),
name,
handler,
...,
position = NULL) {
event <- match_arg(event)
assert_function(handler, self$events$request[[event]]$args)
event <- switch(
event,
header = "header",
before = "before-request",
request = "request",
after = "after-request"
)
self$handle(event, name, handler, ..., position = position)
},
#' @description Websocket Event Handler
#'
#' **Arguments**
#'
#' * `server` - application itself
#' * `id` - client identifier
#' * `request` - request used to establish the websocket connection
#' * `message` - message itself
#' * `arg_list` - for `message` event, the return value from the `before`
#' handler, if any.
#' * `binary` - for `message` event, indicating if it is binary.
#' * `response` - for `after` event, the response object
#'
#' **Events**
#'
#' * `before` - before the request; for decoding the message before passing
#' it through; return value is passed to `request` handler
#' as `arg_list`
#' * `message` - main message handling is done here; return value discarded
#' * `after` - after the request; can be used to inspect the response
#' (but not modify it) before sending to the client;
#' return value is discarded
#' * `send` - a websocket message is sent; return value discarded
#'
#' @param ... (arg) key value pairs of attributes to attach to handler
handle_ws = function(event = c("before", "message", "after",
"send", "closed"),
name,
handler,
...,
position = NULL) {
event <- match_arg(event)
assert_function(handler, self$events$ws[[event]]$args)
event <- switch(
event,
before = "before-message",
message = "message",
after = "after-message",
send = "send",
closed = "websocket-closed"
)
self$handle(event, name, handler, ..., position = position)
},
#' @description handle Triggers an event for the handlers
#' @param event (str) event name
#' @param ... (arg) args passed to handler
#' @param check (flg) check whether this is protected
handle_trigger = function(event, ..., check = TRUE) {
self$fire$trigger(event, ..., check = check)
return(invisible(self))
},
#' @description Adds a route handler
#' @param path (str) endpoint
#' @param name (str) human-readable friendly name
#' @param methods (chr) combination of GET, POST, PUT, PATCH, DELETE
#' @param handler (fun) handler; must have arguments
#' `request`, `response`, `keys`, `...`.
#' @param attach (str) event to attach. defaults to `request`.
#' @param priority (int) relative positioning of the handler; lower will be
#' executed first.
#' @param replace (flg) whether or not to replace same name or error out
#' @param ... (dta) extra metadata to identify thion_atts route.
router = function(path,
handler,
...,
name = path,
methods = "get",
attach = "request",
priority = 0L,
replace = FALSE) {
assert_subset(attach, c("request", "message", "header"))
assert_route_handler(handler)
walk(
attach,
function(attach, metadata) {
router_id <- self$fire$on_router(
path = path,
handler = private$router_handler(handler),
name = name,
methods = methods,
attach = attach,
priority = priority,
replace = replace
)
private$set_metadata("routers", .list = set_names(
list(set_names(list(metadata), router_id)),
attach
))
self$log("info", "Router {name} on path {path} attached")
},
metadata = assert_named(list(..., name = name))
)
return(invisible(self))
},
#' @description Find routers based on metadata
#' @param ... (sel) selector expressions
router_find = function(...,
attach = c("request", "message", "header"),
discard = FALSE) {
attach <- match_arg(attach) %||% "request"
private$find_element(
self$metadata$routers[[attach]],
...,
discard = discard
)
},
#' @description Remove routers based on metadata
router_remove = function(...,
attach = c("request", "message", "header"),
discard = FALSE) {
attach <- match_arg(attach) %||% "request"
walk(
self$router_find(..., attach = attach, discard = discard),
function(router_id, attach) {
self$fire$off_router(router_id, attach = attach)
private$set_metadata(
"routers",
.list = set_names(list(set_names(list(NULL), router_id)), attach)
)
},
attach = attach
)
return(invisible(self))
},
#' @description Adds a route for server static files
#' @param path (url) URL path to serve
#' @param name (str) human-readable friendly name
#' @param file (pth) directory to serve on that path
#' @param index_html (flg) whether or not to serve when index.html exists
#' @param fallthrough (flg) if not available, use R callback
#' @param html_charset (str) html charset, defaults to UTF-8
#' @param headers (lst) headers that are included with the response
#' @param validation (chr) character vector of headers needed
#' @param replace (flg) if already exists, overwrite
#' @param ... (dta) extra metadata to identify this static path.
static = function(path, file, ...,
name = path,
index_html = TRUE,
fallthrough = FALSE,
html_charset = "utf-8",
headers = list(),
validation = character(0),
replace = FALSE) {
metadata <- assert_named(list(..., name = name))
static_id <- self$fire$on_static(
path = path,
file = file,
name = name,
index_html = index_html,
fallthrough = fallthrough,
html_charset = html_charset,
headers = headers,
validation = validation,
replace = replace
)
private$set_metadata(
"statics",
.list = set_names(list(metadata), static_id)
)
self$log("info", "Path {name} on path {path} attached")
return(invisible(self))
},
#' @description Find static paths based on metadata
static_find = function(..., discard = FALSE) {
private$find_element(
self$metadata$statics,
...,
discard = discard
)
},
#' @description Remove static paths based on metadata
static_remove = function(..., discard = FALSE) {
walk(
self$static_find(..., discard = discard),
function(static_id) {
self$fire$off_static(static_id)
private$set_metadata(
"statics",
.list = set_names(list(NULL), static_id)
)
}
)
return(invisible(self))
},
#' @description Send a websocket message
#' @param message (lst) websocket message
#' @param id (str) client identifier; all clients if missing (for send)
ws_send = function(message, id) {
if (!is.character(message))
message <- paste0(as.character(message), collapse = " ")
self$fire$send(message = message, id = id)
return(invisible(self))
},
#' @description Close a websocket connection
#' @param id (str) client identifier
ws_close = function(id) {
assert_string(id)
self$fire$close_ws_con(id)
return(invisible(self))
},
#' @description Attach a plugin
#' @param plugin (Plugin) instance
#' @param ... (arg) passed to the plugin's `on_attach` method
#' @param force (flg) force to attach even if there is already existing
#' @param bind (flg) add an active binding to fetch the plugin itself
#' @param clean (flg) remove the attach methods once they have already
#' been run to clean up the interface
plugin_attach = function(plugin, ...,
force = FALSE,
bind = TRUE,
clean = TRUE) {
# Validation
assert_class(plugin, "Plugin")
name <- assert_string(plugin$name)
if (bind & !force) assert_false(name %in% names(self))
# Either force is applied or the plugin is not yet attached
assert_true(force || !name %in% names(self$plugins))
# If force, and the plugin exists, run the detach method first.
if (name %in% names(self$plugins) && force) self$plugin_detach(name)
# If any plugins are required, ensure that they are attached
requires <- plugin$requires
if (length(requires) > 0) {
assert_character(requires)
walk(requires, ~assert_true(self$plugin_has(.)))
}
# Attach the plugin
plugin$on_attach(app = self, ...)
# Record the plugin
private$.plugins <- modifyList(
private$.plugins,
set_names(list(plugin), name)
)
# Bind the plugin
if (bind) {
if (clean) {
makeActiveBinding(
name,
function() {
clean_names <- setdiff(
names(self$plugins[[name]]),
c(".__enclos_env__", "app", "config", "requires", "name",
"initialize", "clone", "set_config", "on_attach", "on_detach",
"metadata", "fire")
)
map(clean_names, ~plugin[[.]]) %>%
set_names(clean_names)
},
self
)
} else {
makeActiveBinding(
name,
function() self$plugins[[name]],
self
)
}
}
return(invisible(self))
},
#' @description Detach a plugin
#' @param name (str) name of the plugin to detach
plugin_detach = function(name, ...) {
assert_string(name)
assert_choice(name, names(private$.plugins))
# Detach the plugin
self$plugins[[name]]$on_detach(app = self, ...)
# Remove the plugin and binding
rm(list = name, envir = self)
private$.plugins[[name]] <- NULL
return(invisible(self))
},
#' @description Detach all plugins
plugin_detach_all = function(...) {
walk(self$plugins, ~.$on_detach(app = self, ...))
private$.plugins <- list()
},
#' @description Check if a plugin of a class is attached
#' @param class (str) class of the plugin
plugin_has = function(class) {
assert_string(class)
some(self$plugins, ~test_class(., class))
},
#' @description Check if a plugin of a class is attached
#' @param class (str) class of the plugin
plugin_get = function(class) {
assert_string(class)
keep(self$plugins, ~test_class(., class)) %>%
when(length(.) == 1, .[[1]])
},
#' @description print method
print = function() print(self$fire)
),
active = list(
#' @field plugins read-only field for plugins attached
plugins = function() private$.plugins,
#' @field fire read-only field for the fire object
fire = function() private$.fire,
#' @field handles read-only field for the handles attached
handles = function() self$fire$handles,
#' @field routers read-only field for the routers attached
routers = function() self$fire$routers,
#' @field statics read-only field for the paths attached
statics = function() self$fire$statics,
#' @field data alternative way of accessing application data
data = function() self$fire$data,
#' @field sockets read-only list of active websockets
sockets = function() self$fire$sockets,
#' @field events help information
events = function() private$.events
),
private = list(
# Events help
.events = list(),
# Holds the attached plugins
.plugins = list(),
# Holds the `fiery::Fire` objects
.fire = NULL,
# Generate a router handler
router_handler = function(handler) {
function(request, response, keys, ...) {
continue <- handler(request, response, keys, ...)
response$type <- response$get_data("type") %||% response$type
if (response$status == 404L) response$status <- 200L
if (!test_flag(continue)) continue <- TRUE
return(continue)
}
}
)
)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.