test_that("App initializes", {
app <- expect_r6(App$new(), "App")
expect_error(App$new(port = 8438484))
expect_r6(app$fire, "Fire")
# Alternative initializations
expect_r6(
App$new(
client_id_converter = function(request) request$headers$Client_Id,
headers = list(X_Powered_By = "webtools")
),
"App"
)
})
test_that("App can start and stop", {
app <- App$new(logger = logger_console())
expect_output(app$lifecycle_start(), ".*start: 0.0.0.0:3838.*")
expect_true(app$lifecycle_is_running())
expect_error(app$lifecycle_stop(), NA)
expect_false(app$lifecycle_is_running())
stop_all()
})
test_that("Client ID converter works", {
app <- App$new(TestPlugin$new())
app$set_client_id_converter(function(request) {
return(request$headers$Client_Id)
})
app$handle_request(
event = "before",
name = "set_id",
function(server, id, request, ...) {
return(list(client_id = id))
}
)
app$router("/", function(request, response, keys, arg_list, ...) {
response$body <- arg_list$client_id
response$status <- 200L
return(FALSE)
})
client_id <- stri_rand_strings(1, 12)
res <- app$test$request("/", headers = list(Client_Id = client_id))
expect_equal(res$body, client_id)
res <- app$test$request(
"/?ws=trial",
headers = list(Client_Id = client_id, Upgrade = "websocket")
)
expect_equal(paste0(client_id, "+trial"), res$body)
expect_class(app$sockets, "environment")
})
test_that("Global header setting works", {
app <- App$new(TestPlugin$new())
app$set_headers(X_Powered_By = "webtools")
res <- app$test$request("/")
expect_equal(res$headers$X_Powered_By, "webtools")
})
test_that("Logging works", {
app <- App$new(TestPlugin$new(), logger = logger_console())
expect_output(app$log("warn", "Hello!"))
app$handle_cycle("start", "cycle logger", function(server, ...) {
server$set_data("cycles", (server$get_data("cycles") %||% 0) + 1L)
server$log("info", server$get_data("cycles"))
})
with_tempfile("logfile", {
app$set_logger(logger_file(file = logfile, format = "{request$method}"))
cycles <- sample(1:10, 1)
for (i in 1:cycles) app$test$request("/")
expect_length(readLines(logfile), cycles)
})
})
test_that("Application data settings work", {
app <- App$new()
app$set_data("hello", 1)
expect_equal(app$get_data("hello"), 1)
expect_equal(app$data$hello, 1)
app$set_data("hi", list(option1 = 2))
expect_equal(app$get_data("hi")$option1, 2)
expect_equal(app$data$hi$option1, 2)
app$set_data("hi", list(option2 = 3))
expect_equal(app$get_data("hi")$option1, 2)
expect_equal(app$data$hi$option1, 2)
expect_equal(app$get_data("hi")$option2, 3)
expect_equal(app$data$hi$option2, 3)
app$set_data("hello", NULL)
expect_null(app$get_data("hello"))
expect_null(app$data$hello)
app$clear_data()
expect_length(app$data, 0L)
})
test_that("Handler attach and detach functions work", {
app <- App$new()
expect_null(app$handles$start)
app$handle("start", "starter", function(server, ...) {
server$set_data("started", Sys.time())
})
expect_false(is.null(app$handles$start))
app$lifecycle_start()
start_time <- expect_posixct(app$get_data("started"))
app$lifecycle_stop()
expect_string(app$handle_find(name == "starter"))
app$handle_remove(name == "starter")
expect_length(app$handle_find(name == "starter"), 0L)
app$lifecycle_start()
expect_equal(app$get_data("started"), start_time)
app$lifecycle_stop()
app$handle("start", "starter", function(server, ...) {
server$set_data("started", Sys.time())
}, type = "starter")
expect_string(app$handle_find(type == "starter"))
app$handle_remove(type == "starter")
expect_length(app$handle_find(~type == "starter"), 0L)
app$handle("start", "starter", function(server, ...) {
server$set_data("started", Sys.time())
}, type = "starter")
app$handle("start", "starter2", function(server, ...) {
server$set_data("started", Sys.time())
}, type = "starter2")
app$handle_remove(type == "starter2", discard = TRUE)
expect_string(app$handle_find(name == "starter2"))
expect_length(app$handle_find(name == "starter"), 0L)
app$handle("start", "starter", function(server, ...) {
server$set_data("started", Sys.time())
}, type = "starter")
app$handle_remove(name == "starter2", discard = TRUE)
expect_string(app$handle_find(name == "starter2"))
expect_length(app$handle_find("starter"), 0L)
})
test_that("Lifecycle handlers work", {
app <- App$new()
app$handle_lifecycle("start", "start", function(server, ...) {
server$set_data("started", TRUE)
})
app$handle_lifecycle("end", "end", function(server, ...) {
server$set_data("ended", TRUE)
})
expect_null(app$get_data("started"))
app$lifecycle_start()
expect_true(app$get_data("started"))
expect_null(app$get_data("ended"))
app$lifecycle_stop()
expect_true(app$get_data("ended"))
})
test_that("Cycle handlers work", {
app <- App$new()
app$handle_cycle("start", "start", function(server, ...) {
server$set_data("cycle_started", TRUE)
})
app$handle_cycle("end", "end", function(server, ...) {
server$set_data("cycle_ended", TRUE)
})
app$handle_trigger("cycle-start", check = FALSE)
app$handle_trigger("cycle-end", check = FALSE)
expect_true(app$get_data("cycle_started"))
expect_true(app$get_data("cycle_ended"))
})
test_that("Request handlers work", {
app <- App$new(TestPlugin$new())
app$handle_request("header", "header", function(server, id, request, ...) {
server$set_data("header", request$headers$Header)
return(TRUE)
})
app$handle_request("before", "before", function(server, id, request, ...) {
return(list(before = request$headers$Before))
})
app$handle_request(
"request", "request", function(server, id, request, arg_list, ...) {
response <- request$respond()
response$body <- arg_list$before
response$status <- 200L
}
)
app$handle_request(
"after", "after", function(server, id, request, response, ...) {
server$set_data("after", TRUE)
}
)
before <- stri_rand_strings(1, 12)
res <- app$test$request("/", headers = list(Before = before))
expect_equal(res$body, before)
expect_true(app$get_data("after"))
})
test_that("Websocket handlers work", {
app <- App$new(TestPlugin$new())
app$set_client_id_converter(function(request) {
return(request$headers$Client_Id)
})
app$handle_ws(
"before",
"before",
function(server, id, binary, message, request, ...) {
return(list(
message = paste0(message, "_APPEND"),
binary = FALSE,
client = id,
before = TRUE
))
}
)
app$handle_ws(
"message",
"message",
function(server, id, request, message, arg_list, binary) {
server$set_data("client_id", arg_list$client)
server$set_data("message", message)
server$set_data("binary", binary)
server$send(paste0(message, "_echo"))
}
)
app$handle_ws(
"after",
"after",
function(server, id, request, message, arg_list, binary) {
server$set_data("after", TRUE)
}
)
app$handle_ws(
"closed",
"closed",
function(server, id, request, arg_list, binary) {
server$set_data("closed", TRUE)
}
)
app$handle_ws(
"send",
"send",
function(server, id, message) {
server$set_data("send", message)
}
)
message <- stri_rand_strings(1, 12)
client_id <- stri_rand_strings(1, 12)
app$test$message(
message = message,
binary = TRUE,
headers = list(
client_id = client_id
)
)
expect_equal(app$get_data("client_id"), client_id)
expect_equal(app$get_data("message"), paste0(message, "_APPEND"))
expect_false(app$get_data("binary"))
expect_true(app$get_data("after"))
expect_true(app$get_data("closed"))
expect_equal(app$get_data("send"), paste0(message, "_APPEND_echo"))
})
test_that("manual handle trigger works", {
app <- App$new()
message <- stri_rand_strings(1, 12)
app$handle("custom", "custom",
function(server, message) server$set_data("custom", message))
app$handle_trigger("custom", message = message)
expect_equal(app$get_data("custom"), message)
})
test_that("Router attachment and detachment functions work", {
app <- App$new(TestPlugin$new())
message <- stri_rand_strings(1, 12L)
app$router(
"/",
function(request, response, keys, ...) {
response$body <- message
response$type <- "html"
response$status <- 200
return(FALSE)
},
type = "html"
)
app$router(
"/plain",
function(request, response, keys, ...) {
response$body <- message
response$set_data("type", "text/plain")
response$status <- 200
return(FALSE)
},
type = "plain"
)
app$router(
"/noreturn",
function(request, response, keys, ...) {
response$body <- message
response$set_data("type", "text/plain")
response$status <- 200
}
)
app$router(
"/error",
function(request, response, keys, ...) {
stop("Forced Error")
return(FALSE)
},
type = "error"
)
res <- app$test$request("/")
expect_equal(res$status, 200L)
expect_equal(res$headers$`Content-Type`, "text/html")
expect_equal(res$body, message)
res <- app$test$request("/plain")
expect_equal(res$status, 200L)
expect_equal(res$headers$`Content-Type`, "text/plain")
expect_equal(res$body, message)
res <- app$test$request("/error")
expect_equal(res$status, 500L)
res <- app$test$request("/noreturn")
expect_equal(res$status, 200L)
expect_equal(res$body, message)
res <- app$test$request("/missing")
expect_equal(res$status, 404L)
expect_equal(app$router_find(type == "plain"), "/plain")
app$router_remove(type == "plain")
res <- app$test$request("/plain")
expect_length(app$router_find(name == "/plain"), 0L)
expect_equal(res$status, 404L)
expect_length(app$router_find(), 3L)
app$router_remove()
expect_length(app$router_find(), 0L)
res <- app$test$request("/")
expect_equal(res$status, 404L)
})
test_that("Static path attachment and detachment functions work", {
app <- App$new()
with_tempdir(app$static("test1", getwd(), type = "test"))
with_tempdir(app$static("test2", getwd(), type = "test"))
with_tempdir(app$static("test3", getwd(), type = "test"))
expect_class(app$statics$test1, "staticPath")
expect_length(app$static_find(name == "test1"), 1)
expect_length(app$static_find(type == "test"), 3)
app$static_remove(name == "test1")
expect_length(app$static_find("test1"), 0)
app$static_remove(type == "test")
expect_length(app$metadata$statics, 0)
})
test_that("Websocket sending and closing works", {
app <- App$new()
app$handle_ws("send", "send", function(server, id, message) {
server$set_data("sent", message)
})
app$handle_ws("closed", "closed", function(server, id, request) {
server$set_data("closed", id)
})
app$ws_send("Hello", "dummy")
expect_equal(app$get_data("sent"), "Hello")
app$ws_send(list(A = 1, B = 2), "dummy")
expect_equal(app$get_data("sent"), "1 2")
expect_error(app$ws_close("dummy"), NA)
})
test_that("Plugin functionality works", {
app <- App$new(TestPlugin$new())
# Simple attach and detach
app$plugin_attach(RoutePlugin$new("/plugin", "Hello World!"))
expect_length(app$metadata$routers$request, 1L)
expect_true(app$plugin_has("RoutePlugin"))
expect_r6(app$plugin_get("RoutePlugin"), "RoutePlugin")
app$plugin_detach("route")
expect_length(app$metadata$routers$request, 0L)
# Attach and detach all
app$plugin_attach(RoutePlugin$new("/plugin", "Hello World!"))
expect_length(app$metadata$routers$request, 1L)
res <- app$test$request("/plugin")
expect_equal(res$status, 200L)
expect_equal(res$body, "Hello World!")
app$plugin_detach_all()
expect_length(app$metadata$routers$request, 0L)
expect_false(app$plugin_has("RoutePlugin"))
# Attach exception handling
app <- App$new()
app$plugin_attach(RoutePlugin$new("/plugin", "Hello World!"))
expect_error(
app$plugin_attach(RoutePlugin$new("/plugin", "Hello World!"))
)
expect_error(
app$plugin_attach(RoutePlugin$new("/plugin", "Hello World!"), force = TRUE),
NA
)
expect_error(
app$plugin_attach(RoutePlugin$new("/plugin", "Hello World!"))
)
expect_list(app$route, names = "named")
expect_error(
app$plugin_attach(RoutePlugin$new("/plugin", "Hello World!"),
force = TRUE,
bind = FALSE),
NA
)
expect_null(app$route)
# Unclean binding
app <- App$new()
app$plugin_attach(RoutePlugin$new("/plugin", "Hello World!"), clean = FALSE)
expect_identical(app$route$app, app)
})
test_that("App misc functions work", {
app <- App$new()
expect_error(app$browse(), NA)
expect_output(app$print(), "fiery webserver")
})
stop_all()
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.