R/fire.R
In tjpalanca/webtools: Web Server Tools
#' @title
#' Fire Application
#'
#' @description
#' Modified [`fiery::Fire`] class definition that includes some improvements:
#'
#' * Takes advantage of [`httpuv::staticPath()`] to serve static 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.
#'
#' @param name (str) human-readable friendly name
#' @param attach (str) event to attach. defaults to `request`.
#' @param ... (arg) extra arguments
#'
#' @name Fire
Fire <- R6Class(
classname = "Fire",
inherit = fiery::Fire,
public = list(
#' @description Triggers an event
#' @param event (str) event name
#' @param ... (arg) args passed to handler
#' @param check (flg) check whether this is protected
trigger = function(event, ..., check = TRUE) {
assert_flag(check)
assert_string(event)
if (check) assert_false(event %in% private$privateTriggers)
private$p_trigger(event, server = self, ...)
},
#' @description Add a route
#' @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 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 this route.
on_router = function(path,
handler,
...,
name = path,
methods = "get",
attach = c("request", "message", "header"),
priority = 0L,
replace = FALSE) {
assert_string(path)
assert_string(name)
assert_subset(methods, c("get", "post", "put", "patch", "delete"))
assert_route_handler(handler)
attach <- match_arg(attach) %||% "request"
assert_int(priority, lower = -999L, upper = +999L)
assert_flag(replace)
router <- Route$new()
walk(methods, ~router$add_handler(., path, handler))
attr(router, "priority") <- priority
if (!replace && name %in% names(self$routers[[attach]])) {
stop("Name already exists and replace = FALSE")
}
private$.routers[[attach]] <- modifyList(
self$routers[[attach]] %||% list(),
set_names(list(router), name)
)
invisible(name)
},
#' @description Remove a route
off_router = function(name, attach = c("request", "message", "header")) {
assert_string(name)
attach <- assert_string(match_arg(attach) %||% "request")
assert_choice(name, names(self$routers[[attach]]))
private$.routers[[attach]][[name]] <- NULL
invisible(NULL)
},
#' @description Add a static handler
#' @param path (url) URL path to serve
#' @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.
on_static = function(path,
file,
name = path,
index_html = TRUE,
fallthrough = FALSE,
html_charset = "utf-8",
headers = list(),
validation = character(0),
replace = FALSE) {
assert_string(path)
assert(test_directory_exists(file), test_file_exists(file))
assert_string(name)
assert_flag(index_html)
assert_flag(fallthrough)
assert_string(html_charset)
assert_list(headers)
assert_character(validation)
assert_flag(replace)
static <- staticPath(
path = file,
indexhtml = index_html,
fallthrough = fallthrough,
html_charset = html_charset,
headers = headers,
validation = validation
)
if (!replace && name %in% names(self$statics)) {
stop("Name already exists and replace = FALSE")
}
private$.statics <- modifyList(
self$statics,
set_names(list(static), path)
)
invisible(path)
},
#' @description Remove a static handler
off_static = function(name) {
assert_string(name)
assert_choice(name, names(private$.statics))
private$.statics[[name]] <- NULL
invisible(NULL)
},
#' @description Builds the route stack and attaches it as a plugin
#' @param force (flg) force the attachment of the routes
build_routers = function(..., force = TRUE) {
iwalk(self$routers, function(routers, attach) {
routers <- routers[order(map_int(routers, attr, "priority"))]
stack <- RouteStack$new(
path_extractor = self$path_extractor %||% function(msg, bin) "/"
)
stack$attach_to <- attach
iwalk(routers, ~stack$add_route(.x, .y))
self$attach(stack, ..., force = force)
private$.plugins[[glue(attach, "_routr")]]
})
return(invisible(self))
},
#' @description This is a modified version of attach that returns the
#' handler IDs associated, so that they can be removed later on.
#' @param plugin (ApplicationPlugin) to attach
#' @param ... (arg) passed to the plugin's `on_attach()` method
#' @param force (flg) force attaching the plugin
attach = function(plugin, ..., force = FALSE) {
# Valid name
name <- assert_string(plugin$name)
# Either force is applied or the plugin is not yet attached
assert_true(force || !self$has_plugin(name))
if (force && self$has_plugin(name)) self$detach(name)
# If any plugins are required, ensure that they are attached
requires <- plugin$require
if (length(requires) > 0) {
assert_character(requires)
walk(requires, ~assert_true(self$has_plugin(.)))
}
# Attach the plugin
handler_id <- plugin$on_attach(self, ...)
assert_string(handler_id)
# Record the plugin handler
private$.plugins <- modifyList(
private$.plugins,
set_names(list(handler_id), name)
)
# Record the plugin
private$add_plugin(plugin, name)
return(invisible(self))
},
#' @description Detaches a plugin
#' @param name (str) name of the plugin
detach = function(name) {
walk(private$.plugins[[name]], self$off)
private$.plugins[[name]] <- NULL
private$pluginList[[name]] <- NULL
return(invisible(self))
},
#' @description Detaches all plugins
detach_all = function() {
walk(private$.plugins, ~walk(., self$off))
private$.plugins <- list()
private$pluginList <- list()
return(invisible(self))
},
#' @description Browse to the App URL
browse = function() {
private$open_browser()
return(invisible(self))
},
#' @description Clear all data
clear_data = function() {
private$data <- new.env(parent = emptyenv())
},
#' @field path_extractor function that transforms websocket to a path
path_extractor = NULL
),
active = list(
#' @field url Application URL
url = function() {
host <- if (self$host == "0.0.0.0") "localhost" else self$host
glue("http://{host}:{self$port}/{self$root}")
},
#' @field data read application data
data = function() as.list(private$data),
#' @field routers read-only list of routers
routers = function() private$.routers,
#' @field handles read-only list of handlers
handles = function() as.list(private$handlers),
#' @field statics read-only list of statics
statics = function() private$.statics,
#' @field events helpful guide to function arguments
events = function() private$.events,
#' @field sockets read-only list of active websockets
sockets = function() private$websockets
),
private = list(
# function arguments needed
.events = list(
start = list(
trigger = "once when the app is started but before it is running",
args = c("server", "..."),
return = "discarded"
),
resume = list(
trigger = "once after the start event if the app has been started",
args = c("server", "..."),
return = "discarded"
),
end = list(
trigger = "once after the app is stopped",
args = c("server"),
return = "discarded"
),
`cycle-start` = list(
trigger =
"in the beginning of each loop, before the request queue is flushed",
args = c("server"),
return = "discarded"
),
`cycle-end` = list(
trigger = str_squish(
"in the end of each loop, after the request queue is flushed and all
delayed, timed, and asynchronous calls have been executed"
),
args = c("server"),
return = "discarded"
),
header = list(
trigger = "every time the header of a request is received",
args = c("server", "id", "request"),
return = "T/F if further processing of the request will be done"
),
`before-request` = list(
trigger = "prior to handling of a request",
args = c("server", "id", "request"),
return = "passed on to request handlers as arg_list"
),
request = list(
trigger = "after the before-request; main request handling",
args = c("server", "id", "request", "arg_list"),
return = "sent back as response; 404 if no handler, 500 if invalid"
),
`after-request` = list(
trigger = "inspect the response before send to client; no modifying",
args = c("server", "id", "request"),
return = "discarded"
),
`before-message` = list(
trigger = "when a websocket message is received",
args = c("server", "id", "binary", "message", "request"),
return = str_squish(
"passed on to message handlers as arg_list;
binary or message will replace the value"
)
),
message = list(
trigger = "primary websocket message handling",
args = c("server", "id", "binary", "message", "request", "arg_list"),
return = "discarded; websocket is bidirectional"
),
`after-message` = list(
trigger = "after the message",
args = c("server", "id", "binary", "message", "request"),
return = "discarded"
),
send = list(
trigger = "sent websocket message to client",
args = c("server", "id", "message"),
return = "discarded"
),
`websocket-closed` = list(
trigger = "websocket connection is closed",
args = c("server", "id", "request"),
return = "discarded"
)
),
# plugin handler ids
.plugins = list(),
# List where static paths are kept, to add to the httpuv run command
.statics = list(),
# List where routers are kept, to be built into route stacks
.routers = list(),
# Blocking server, adding the static paths
run_blocking_server = function(showcase = FALSE) {
self$build_routers()
server <- startServer(
self$host,
self$port,
private$run_parameters()
)
on.exit(stopServer(server))
if (showcase) private$open_browser() # nocov
while (TRUE) {
private$p_trigger("cycle-start", server = self)
service()
private$external_triggers()
private$safe_call(private$DELAY$eval(server = self))
private$safe_call(private$TIME$eval(server = self))
private$safe_call(private$ASYNC$eval(server = self))
private$try_catch(private$LOG_QUEUE$eval(server = self))
private$p_trigger("cycle-end", server = self)
if (private$quitting) {
private$quitting <- FALSE
break
}
Sys.sleep(self$refresh_rate)
}
},
# Allowing server, running the static paths
run_allowing_server = function(showcase = FALSE) {
self$build_routers()
private$server <- startDaemonizedServer(
self$host,
self$port,
private$run_parameters()
)
if (showcase) private$open_browser() # nocov
private$allowing_cycle()
},
# Adding the `staticPaths` argument
run_parameters = function() {
list(
call = private$request_logic,
onHeaders = private$header_logic,
onWSOpen = private$websocket_logic,
staticPaths = private$.statics
)
},
# Needed as a better try-catch, imported from `fiery`
try_catch = function(expr) {
tryCatch(expr, error = function(e) e)
},
# Open browser method that is more suited to RStudio Server
open_browser = function() {
if (isAvailable()) {
viewer(self$url) # nocov
} else {
browseURL(self$url)
}
}
)
)
#' @title Autocompletion Helpers
#'
#' @description
#' Instantiated objects to assist with autocompletion when constructing
#' handlers. These may not be exactly the same as those seen in production.
#'
#' @name autocomplete
NULL
#' @rdname autocomplete
#' @export
server <- Fire$new()
#' @rdname autocomplete
#' @export
request <- Request$new(fake_request("https://example.com"))
#' @rdname autocomplete
#' @export
response <- Response$new(request)
response$body <- c(file = "dummy")
#' @rdname autocomplete
#' @export
formatters <- default_formatters
#' @rdname autocomplete
#' @export
parsers <- default_parsers
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
#' Fire Application
#'
#' @description
#' Modified [`fiery::Fire`] class definition that includes some improvements:
#'
#' * Takes advantage of [`httpuv::staticPath()`] to serve static 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.
#'
#' @param name (str) human-readable friendly name
#' @param attach (str) event to attach. defaults to `request`.
#' @param ... (arg) extra arguments
#'
#' @name Fire
Fire <- R6Class(
classname = "Fire",
inherit = fiery::Fire,
public = list(
#' @description Triggers an event
#' @param event (str) event name
#' @param ... (arg) args passed to handler
#' @param check (flg) check whether this is protected
trigger = function(event, ..., check = TRUE) {
assert_flag(check)
assert_string(event)
if (check) assert_false(event %in% private$privateTriggers)
private$p_trigger(event, server = self, ...)
},
#' @description Add a route
#' @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 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 this route.
on_router = function(path,
handler,
...,
name = path,
methods = "get",
attach = c("request", "message", "header"),
priority = 0L,
replace = FALSE) {
assert_string(path)
assert_string(name)
assert_subset(methods, c("get", "post", "put", "patch", "delete"))
assert_route_handler(handler)
attach <- match_arg(attach) %||% "request"
assert_int(priority, lower = -999L, upper = +999L)
assert_flag(replace)
router <- Route$new()
walk(methods, ~router$add_handler(., path, handler))
attr(router, "priority") <- priority
if (!replace && name %in% names(self$routers[[attach]])) {
stop("Name already exists and replace = FALSE")
}
private$.routers[[attach]] <- modifyList(
self$routers[[attach]] %||% list(),
set_names(list(router), name)
)
invisible(name)
},
#' @description Remove a route
off_router = function(name, attach = c("request", "message", "header")) {
assert_string(name)
attach <- assert_string(match_arg(attach) %||% "request")
assert_choice(name, names(self$routers[[attach]]))
private$.routers[[attach]][[name]] <- NULL
invisible(NULL)
},
#' @description Add a static handler
#' @param path (url) URL path to serve
#' @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.
on_static = function(path,
file,
name = path,
index_html = TRUE,
fallthrough = FALSE,
html_charset = "utf-8",
headers = list(),
validation = character(0),
replace = FALSE) {
assert_string(path)
assert(test_directory_exists(file), test_file_exists(file))
assert_string(name)
assert_flag(index_html)
assert_flag(fallthrough)
assert_string(html_charset)
assert_list(headers)
assert_character(validation)
assert_flag(replace)
static <- staticPath(
path = file,
indexhtml = index_html,
fallthrough = fallthrough,
html_charset = html_charset,
headers = headers,
validation = validation
)
if (!replace && name %in% names(self$statics)) {
stop("Name already exists and replace = FALSE")
}
private$.statics <- modifyList(
self$statics,
set_names(list(static), path)
)
invisible(path)
},
#' @description Remove a static handler
off_static = function(name) {
assert_string(name)
assert_choice(name, names(private$.statics))
private$.statics[[name]] <- NULL
invisible(NULL)
},
#' @description Builds the route stack and attaches it as a plugin
#' @param force (flg) force the attachment of the routes
build_routers = function(..., force = TRUE) {
iwalk(self$routers, function(routers, attach) {
routers <- routers[order(map_int(routers, attr, "priority"))]
stack <- RouteStack$new(
path_extractor = self$path_extractor %||% function(msg, bin) "/"
)
stack$attach_to <- attach
iwalk(routers, ~stack$add_route(.x, .y))
self$attach(stack, ..., force = force)
private$.plugins[[glue(attach, "_routr")]]
})
return(invisible(self))
},
#' @description This is a modified version of attach that returns the
#' handler IDs associated, so that they can be removed later on.
#' @param plugin (ApplicationPlugin) to attach
#' @param ... (arg) passed to the plugin's `on_attach()` method
#' @param force (flg) force attaching the plugin
attach = function(plugin, ..., force = FALSE) {
# Valid name
name <- assert_string(plugin$name)
# Either force is applied or the plugin is not yet attached
assert_true(force || !self$has_plugin(name))
if (force && self$has_plugin(name)) self$detach(name)
# If any plugins are required, ensure that they are attached
requires <- plugin$require
if (length(requires) > 0) {
assert_character(requires)
walk(requires, ~assert_true(self$has_plugin(.)))
}
# Attach the plugin
handler_id <- plugin$on_attach(self, ...)
assert_string(handler_id)
# Record the plugin handler
private$.plugins <- modifyList(
private$.plugins,
set_names(list(handler_id), name)
)
# Record the plugin
private$add_plugin(plugin, name)
return(invisible(self))
},
#' @description Detaches a plugin
#' @param name (str) name of the plugin
detach = function(name) {
walk(private$.plugins[[name]], self$off)
private$.plugins[[name]] <- NULL
private$pluginList[[name]] <- NULL
return(invisible(self))
},
#' @description Detaches all plugins
detach_all = function() {
walk(private$.plugins, ~walk(., self$off))
private$.plugins <- list()
private$pluginList <- list()
return(invisible(self))
},
#' @description Browse to the App URL
browse = function() {
private$open_browser()
return(invisible(self))
},
#' @description Clear all data
clear_data = function() {
private$data <- new.env(parent = emptyenv())
},
#' @field path_extractor function that transforms websocket to a path
path_extractor = NULL
),
active = list(
#' @field url Application URL
url = function() {
host <- if (self$host == "0.0.0.0") "localhost" else self$host
glue("http://{host}:{self$port}/{self$root}")
},
#' @field data read application data
data = function() as.list(private$data),
#' @field routers read-only list of routers
routers = function() private$.routers,
#' @field handles read-only list of handlers
handles = function() as.list(private$handlers),
#' @field statics read-only list of statics
statics = function() private$.statics,
#' @field events helpful guide to function arguments
events = function() private$.events,
#' @field sockets read-only list of active websockets
sockets = function() private$websockets
),
private = list(
# function arguments needed
.events = list(
start = list(
trigger = "once when the app is started but before it is running",
args = c("server", "..."),
return = "discarded"
),
resume = list(
trigger = "once after the start event if the app has been started",
args = c("server", "..."),
return = "discarded"
),
end = list(
trigger = "once after the app is stopped",
args = c("server"),
return = "discarded"
),
`cycle-start` = list(
trigger =
"in the beginning of each loop, before the request queue is flushed",
args = c("server"),
return = "discarded"
),
`cycle-end` = list(
trigger = str_squish(
"in the end of each loop, after the request queue is flushed and all
delayed, timed, and asynchronous calls have been executed"
),
args = c("server"),
return = "discarded"
),
header = list(
trigger = "every time the header of a request is received",
args = c("server", "id", "request"),
return = "T/F if further processing of the request will be done"
),
`before-request` = list(
trigger = "prior to handling of a request",
args = c("server", "id", "request"),
return = "passed on to request handlers as arg_list"
),
request = list(
trigger = "after the before-request; main request handling",
args = c("server", "id", "request", "arg_list"),
return = "sent back as response; 404 if no handler, 500 if invalid"
),
`after-request` = list(
trigger = "inspect the response before send to client; no modifying",
args = c("server", "id", "request"),
return = "discarded"
),
`before-message` = list(
trigger = "when a websocket message is received",
args = c("server", "id", "binary", "message", "request"),
return = str_squish(
"passed on to message handlers as arg_list;
binary or message will replace the value"
)
),
message = list(
trigger = "primary websocket message handling",
args = c("server", "id", "binary", "message", "request", "arg_list"),
return = "discarded; websocket is bidirectional"
),
`after-message` = list(
trigger = "after the message",
args = c("server", "id", "binary", "message", "request"),
return = "discarded"
),
send = list(
trigger = "sent websocket message to client",
args = c("server", "id", "message"),
return = "discarded"
),
`websocket-closed` = list(
trigger = "websocket connection is closed",
args = c("server", "id", "request"),
return = "discarded"
)
),
# plugin handler ids
.plugins = list(),
# List where static paths are kept, to add to the httpuv run command
.statics = list(),
# List where routers are kept, to be built into route stacks
.routers = list(),
# Blocking server, adding the static paths
run_blocking_server = function(showcase = FALSE) {
self$build_routers()
server <- startServer(
self$host,
self$port,
private$run_parameters()
)
on.exit(stopServer(server))
if (showcase) private$open_browser() # nocov
while (TRUE) {
private$p_trigger("cycle-start", server = self)
service()
private$external_triggers()
private$safe_call(private$DELAY$eval(server = self))
private$safe_call(private$TIME$eval(server = self))
private$safe_call(private$ASYNC$eval(server = self))
private$try_catch(private$LOG_QUEUE$eval(server = self))
private$p_trigger("cycle-end", server = self)
if (private$quitting) {
private$quitting <- FALSE
break
}
Sys.sleep(self$refresh_rate)
}
},
# Allowing server, running the static paths
run_allowing_server = function(showcase = FALSE) {
self$build_routers()
private$server <- startDaemonizedServer(
self$host,
self$port,
private$run_parameters()
)
if (showcase) private$open_browser() # nocov
private$allowing_cycle()
},
# Adding the `staticPaths` argument
run_parameters = function() {
list(
call = private$request_logic,
onHeaders = private$header_logic,
onWSOpen = private$websocket_logic,
staticPaths = private$.statics
)
},
# Needed as a better try-catch, imported from `fiery`
try_catch = function(expr) {
tryCatch(expr, error = function(e) e)
},
# Open browser method that is more suited to RStudio Server
open_browser = function() {
if (isAvailable()) {
viewer(self$url) # nocov
} else {
browseURL(self$url)
}
}
)
)
#' @title Autocompletion Helpers
#'
#' @description
#' Instantiated objects to assist with autocompletion when constructing
#' handlers. These may not be exactly the same as those seen in production.
#'
#' @name autocomplete
NULL
#' @rdname autocomplete
#' @export
server <- Fire$new()
#' @rdname autocomplete
#' @export
request <- Request$new(fake_request("https://example.com"))
#' @rdname autocomplete
#' @export
response <- Response$new(request)
response$body <- c(file = "dummy")
#' @rdname autocomplete
#' @export
formatters <- default_formatters
#' @rdname autocomplete
#' @export
parsers <- default_parsers
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.