tests/testthat/test-app.R

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()
tjpalanca/webtools documentation built on Dec. 23, 2021, 11 a.m.